VBA：尝试将所有工作表合并到一个工作簿中的新工作表中
我试图复制所有的工作表，一次一个，并粘贴到一个新的工作表。 这些文件来自多个第三方，所以工作表可以改变。 当我试图确定最后一行Lrow和最后一列Lcol时，我遇到了一个问题，因为一个错误出现说Object doesn't support this property or method 。 我打算把这个提交给我的工作，所以任何帮助与防错或一般的macros观技巧，赞赏。
Sub ws_copy() Dim Lrow As Long Dim Lcol As Long Dim Pasterow As Long Dim WSCount As Integer Dim i As Integer 'On Error Resume Next 'Application.DisplayAlerts = False i = Application.InputBox(prompt:="Enter the place order of first tab to be copied.", Title:="Worksheet Consolidation", Type:=1) If IsEmpty(i) = True Then Exit Sub Else If IsNumeric(i) = False Then MsgBox "Enter a numeric value." Else If IsNumeric(i) = True Then Worksheets.Add(before:=Sheets(1)).Name = "Upload" WSCount = Worksheets.Count For i = i + 1 To WSCount Lrow = Worksheets(i).Find("*", After:=Cells(1, 1), _ LookIn:=xlFormulas, _ Lookat:=xlPart, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row Lcol = Worksheets(i).Find("*", After:=Cells(1, 1), _ LookIn:=xlFormulas, _ Lookat:=xlPart, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row Pasterow = Lrow + 1 Workbook.Worksheets(i).Range(Cells(1, 1), Cells(Lrow, Lcol)).Copy Workbook.Worksheets("Upload").Cells(Pasterow, 1).Paste Next i Else Exit Sub End If End If End If 'On Error GoTo 0 'Application.DisplayAlerts = False End Sub
find最后一行/列的常用方法是：
With Worksheets(i) Lrow = .Cells(.Rows.Count, 1).End(xlUp).Row Lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column End With
心连心
基于以下评论：
由于收到的文件种类繁多，我不能假定任何一列或一行都有最后一段数据。
您应该查看使用Worksheet（ MSDN ）的UsedRange属性。 随着更多数据input到工作表中， UsedRange会扩展。
有些人会避免使用UsedRange因为如果input了一些数据，然后删除， UsedRange将包含这些“空”单元格。 UsedRange将在保存工作簿时自动更新。 但是，就你而言，这听起来不像是一个相关的问题。
一个例子是：
Sub Test() Dim wsSource As Worksheet Dim wsTarget As Worksheet Dim rngSource As Range Dim rngTarget As Range Set wsSource = ThisWorkbook.Worksheets("Sheet1") Set wsTarget = ThisWorkbook.Worksheets("Sheet2") Set rngSource = wsSource.UsedRange rngSource.Copy Destination:=wsTarget.Cells End Sub
这是一个查找工作表中最后使用的行和上次使用的列的方法。 它避免了UsedRange的问题，也不知道哪一行可能有最后一列（哪一列可能有最后一行）。 适应你的目的：
Option Explicit Sub LastRowCol() Dim LastRow As Long, LastCol As Long With Worksheets("sheet1") 'or any sheet If Application.WorksheetFunction.CountA(.Cells) > 0 Then LastRow = .Cells.Find(what:="*", after:=[A1], _ LookIn:=xlFormulas, _ searchorder:=xlByRows, _ searchdirection:=xlPrevious).Row LastCol = .Cells.Find(what:="*", after:=[A1], _ LookIn:=xlFormulas, _ searchorder:=xlByColumns, _ searchdirection:=xlPrevious).Column Else LastRow = 1 LastCol = 1 End If End With Debug.Print LastRow, LastCol End Sub
虽然基本的技术已经被使用了很久，Siddarth Rout在不久前发布了一个增加COUNTA的版本来解释工作表可能为空的情况 – 这是一个有用的补充。
如果要将每张表格上的数据合并到一个MasterSheet中，请运行下面的脚本。
Sub CopyRangeFromMultiWorksheets() Dim sh As Worksheet Dim DestSh As Worksheet Dim Last As Long Dim CopyRng As Range With Application .ScreenUpdating = False .EnableEvents = False End With 'Delete the sheet "RDBMergeSheet" if it exist Application.DisplayAlerts = False On Error Resume Next ActiveWorkbook.Worksheets("RDBMergeSheet").Delete On Error GoTo 0 Application.DisplayAlerts = True 'Add a worksheet with the name "RDBMergeSheet" Set DestSh = ActiveWorkbook.Worksheets.Add DestSh.Name = "RDBMergeSheet" 'loop through all worksheets and copy the data to the DestSh For Each sh In ActiveWorkbook.Worksheets If sh.Name <> DestSh.Name Then 'Find the last row with data on the DestSh Last = LastRow(DestSh) 'Fill in the range that you want to copy Set CopyRng = sh.Range("A1:G1") 'Test if there enough rows in the DestSh to copy all the data If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then MsgBox "There are not enough rows in the Destsh" GoTo ExitTheSub End If 'This example copies values/formats, if you only want to copy the 'values or want to copy everything look at the example below this macro CopyRng.Copy With DestSh.Cells(Last + 1, "A") .PasteSpecial xlPasteValues .PasteSpecial xlPasteFormats Application.CutCopyMode = False End With 'Optional: This will copy the sheet name in the H column DestSh.Cells(Last + 1, "H").Resize(CopyRng.Rows.Count).Value = sh.Name End If Next ExitTheSub: Application.Goto DestSh.Cells(1) 'AutoFit the column width in the DestSh sheet DestSh.Columns.AutoFit With Application .ScreenUpdating = True .EnableEvents = True End With End Sub Function LastRow(sh As Worksheet) On Error Resume Next LastRow = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByRows, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Row On Error GoTo 0 End Function Function LastCol(sh As Worksheet) On Error Resume Next LastCol = sh.Cells.Find(What:="*", _ After:=sh.Range("A1"), _ Lookat:=xlPart, _ LookIn:=xlFormulas, _ SearchOrder:=xlByColumns, _ SearchDirection:=xlPrevious, _ MatchCase:=False).Column On Error GoTo 0 End Function
此外，请参阅下面的链接，其他选项略有不同。