复制所有单元格范围

Question

Sub all_col()
Workbooks("xlsb file").Worksheets("sheet name").Range("A1:CR1048576").Copy_
Workbooks("xlsx file").Worksheets("sheet name").Range("A1")

如何编写更有效的代码将所有单元格范围从一个工作表复制到不同工作簿中的另一个工作表。而不是使用"A1:CR1048576"有没有更好的办法?

Answer 1

尝试使用工作表的userange属性。

Sub all_col()
wb1.Worksheets("sheet name").UsedRange.Copy _
wb2.Worksheets("sheet name").Range("A1")
End Sub

Answer 2

将已关闭工作簿中的工作表复制到此工作簿中的工作表

• 该函数是一个转换为函数的子函数，返回一个布尔值，指示是否成功，即是否没有发生错误。
• 您可以将此代码归类为"导入操作":源工作簿已关闭，而目标工作簿包含该代码。通过"一些更改"，您可以将此代码重写为"导出操作":关闭目标工作簿，源工作簿包含代码。查看文件扩展名，看起来您需要后者。

Option Explicit
Sub WsToWsInThisWorkbookTEST()

Dim GotCopied As Boolean: GotCopied = WsToWsInThisWorkbook( _
"C:TestTest.xlsx", "Sheet1", "A1", "Sheet1", "A1")
If Not GotCopied Then Exit Sub

'Continue with your code e.g.:
MsgBox "Worksheet got copied.", vbInformation
End Sub
Function WsToWsInThisWorkbook( _
ByVal SourceFilePath As String, _
Optional ByVal SourceSheetID As Variant, _
Optional ByVal SourceFirstCell As String = "A1", _
Optional ByVal DestinationSheetID As Variant = "Sheet1", _
Optional ByVal DestinationFirstCell As String = "A1") _
As Boolean
On Error GoTo ClearError
Const ProcName As String = "WsToWsInThisWorkbook"
' Source

If Len(Dir(SourceFilePath)) = 0 Then
MsgBox "Source file '" & SourceFilePath & "' not found.", vbCritical
Exit Function
End If
Dim swb As Workbook: Set swb = Workbooks.Open(SourceFilePath, True, True)
Dim sws As Worksheet: Set sws = swb.Sheets(SourceSheetID)
Dim srg As Range
With sws.UsedRange
Dim lcell As Range: Set lcell = .Cells(.Rows.Count, .Columns.Count)
Set srg = sws.Range(SourceFirstCell, lcell)
End With

' Destination.

Dim dwb As Workbook: Set dwb = ThisWorkbook ' workbook containing this code
Dim dws As Worksheet: Set dws = dwb.Sheets(DestinationSheetID)
Dim dfCell As Range: Set dfCell = dws.Range(DestinationFirstCell)

' Copy.

srg.Copy dfCell

WsToWsInThisWorkbook = True

ProcExit:
On Error Resume Next
If Not swb Is Nothing Then swb.Close SaveChanges:=False
On Error GoTo 0
Exit Function
ClearError:
MsgBox "Run-time error '" & Err.Number & "':" & vbLf & Err.Description, _
vbCritical, ProcName
Resume ProcExit
End Function

Answer 3

提供的大多数答案都可以工作，但UsedRange扩展到格式(参见这个史诗主题)讨论找到最后一行的最佳方法)。

如果这是一个问题，您可以将这些函数包含在原始宏的下面，它将是精确的复制空间:

Sub all_col()
Dim lastRow As Long, lastColumn As Long
With Workbooks("xlsb file").Worksheets("sheet name")
lastRow = FindLastRowInSheet(.Range("A1"))
lastColumn = FindLastColumnInSheet(.Range("A1"))


.Range("A1").Resize(lastRow, lastColumn).Copy_
Workbooks("xlsx file").Worksheets("sheet name").Range ("A1")
End With
End Sub

Function FindLastRowInRange(someColumns As Range) As Long
Const zFx = "=MAX(FILTER(ROW(????),NOT(ISBLANK(????)),0))"

Dim tRng As Range, i As Long, tRow As Long, pRng As Range
With someColumns.Worksheet
Set tRng = Intersect(someColumns.EntireColumn, .UsedRange)

For i = 1 To tRng.Columns.Count

Set pRng = Intersect(tRng.Columns(i), _
Range(.Rows(FindLastRowInRange + 1), .Rows(.Rows.Count)))

If Not pRng Is Nothing Then
tRow = .Evaluate(Replace(zFx, "????", _
pRng.Address, 1, -1))

If tRow > FindLastRowInRange Then _
FindLastRowInRange = tRow

End If
Next i
End With
End Function
Function FindLastRowInSheet(anywhereInSheet As Range) As Long
FindLastRowInSheet = FindLastRowInRange(anywhereInSheet.Worksheet.UsedRange)
End Function

Function findLastColumn(someRows As Range) As Long
Const zFx = "=MAX(FILTER(COLUMN(????),NOT(ISBLANK(????)),0))"

Dim tRng As Range, i As Long, tRow As Long, pRng As Range
With someRows.Worksheet
Set tRng = Intersect(.UsedRange, someRows.EntireRow)

For i = 1 To tRng.Rows.Count

Set pRng = Intersect(tRng.Rows(i), Range(.Rows(.Columns.Count), .Rows(findLastColumn + 1)))

If Not pRng Is Nothing Then
tRow = .Evaluate(Replace(zFx, "????", _
pRng.Address, 1, -1))

If tRow > findLastColumn Then _
findLastColumn = tRow

End If
Next i
End With
End Function

Function FindLastColumnInSheet(anywhereInSheet As Range) As Long
FindLastColumnInSheet = findLastColumn(anywhereInSheet.Worksheet.UsedRange)
End Function