VBA：尝试将所有工作表合并到单个工作簿中的一个新工作表中

Question

I am trying to copy all worksheets, one at a time, and pasting into a new worksheet. These files come from multiple third parties so the worksheets can vary. I'm running into a problem below when trying to determine last row Lrow and last column Lcol because an error appears saying Object doesn't support this property or method . I do plan on submitting this to my work so any help with error proofing or general macro tips are appreciated.

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

A common way to find the last row/column is:

With Worksheets(i)

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

End With

hth

Answer 2

Based on the comment that:

I can't assume any one column or row has the last piece of data because of the variety of the files received.

You should look at using the UsedRange property of the Worksheet ( MSDN ). UsedRange expands as more data is entered onto the worksheet.

Some people will avoid using UsedRange because if some data has been entered, and then deleted then UsedRange will include these 'empty' cells. The UsedRange will update itself when the workbook is saved. However, in your case, it doesn't sound like this is a relevant issue.

An example would be:

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

Here is a method of finding the last used row and last used column in a worksheet. It avoids the issues with UsedRange and also your issues of not knowing which row might have the last column (and which column might have the last row). Adapt to your purposes:

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

Although the basic technique has been long used, Siddarth Rout, some time ago, posted a version adding COUNTA to account for the case where the worksheet might be empty -- a useful addition.

Answer 4

If you want to merge data on each sheet into one MasterSheet, run the script below.

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

Also, see the link below for some other options to do this slightly differently.

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