VBA：嘗試將所有工作表合併到一個工作簿中的一個新工作表中

Question

我試圖複製所有工作表，一次一個，並粘貼到新工作表中。這些文件來自多個第三方，因此工作表可能會有所不同。當我試圖確定最後一行Lrow和最後一列Lcol時，我遇到了一個問題，因爲出現錯誤的地方是Object doesn't support this property or method。我打算將這個提交給我的工作，所以任何有關防錯或一般宏提示的幫助表示讚賞。

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 

Answer 1

找到最後行/列的一般方法是：

With Worksheets(i) 

    Lrow = .Cells(.Rows.Count, 1).End(xlUp).Row 
    Lcol = .Cells(1, .Columns.Count).End(xlToLeft).Column 

End With 

心連心

Answer 2

基於以下評論：

我不能假設任何一個由於收到的文件種類繁多，列或行有最後一段數據。

您應該看看使用工作表的UsedRange屬性（MSDN）。 UsedRange隨着更多數據輸入工作表而擴展。

有些人會避免使用UsedRange，因爲如果一些數據已經輸入，然後刪除，那麼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 

Answer 3

這裏是尋找上次使用的行和最後使用的柱在工作表的方法。它避免了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潰敗，前一段時間，發佈一個版本增加COUNTA，以說明工作表可能是空的情況下 - 一個有益的補充。

Answer 4

如果您想要將每張紙上的數據合併到一張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 

此外，請參閱下面的鏈接，其他選項略有不同。

http://www.rondebruin.nl/win/s3/win002.htm