VBA - 将数据复制到主工作表并在每行旁边插入工作表名称

Question

我有多个工作表，每个工作表仅在前两列中包含数据:

A 列 - ID

B 列 - 名称

我正在尝试将所有这些工作表合并到一个主工作表中。主表的格式应为:

A 列 - 工作表名称(从中复制数据)

B 列 - ID

C 列 - 名称

我找到了一个网站，它的代码或多或少可以做到这一点，但是，在把它弄得一团糟之后，我就无法让它工作了。

该代码有效，因为它复制了正确的范围并将工作表名称输入到 A 列中，但是，它不会在主工作表中范围的“最后一行”处停止，它会继续填充整个列A 和 IF Statement计算行数被触发，我得到 msgbox弹出(见下面的代码)。此时，代码刚刚结束，它没有机会执行剩余的工作表。

网站链接:https://www.rondebruin.nl/win/s3/win002.htm

以下是原始站点的代码，对我将使用的范围进行了一些细微调整:

Sub CopySheetNameToColumn()
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("A:B")

            '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, "B")
                .PasteSpecial xlPasteValues
                .PasteSpecial xlPasteFormats
                Application.CutCopyMode = False
            End With

            'Optional: This will copy the sheet name in the H column
            DestSh.Cells(Last + 1, "A").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

Answer 1

代替
Set CopyRng = sh.Range("A:B")
尝试

Set CopyRng = sh.Range("A1", sh.Range("B" & Rows.Count).End(xlUp))

因为前者涵盖了工作表的每一行，因此消息框和名称贯穿整个工作表。