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))

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

Answer 2

类似：

Option Explicit

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

    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("RDBMergeSheet").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True


    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "RDBMergeSheet"

    For Each sh In ActiveWorkbook.Worksheets

        If sh.Name <> DestSh.Name Then

            Last = GetLastRow(DestSh, 1)

            With sh
                Set CopyRng = sh.Range("A1:B" & GetLastRow(sh, 1))
            End With

            If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
                MsgBox "There are not enough rows in the Destsh"
                GoTo ExitTheSub
            Else

               CopyRng.Copy IIf(Last = 1, DestSh.Cells(1, "B"), DestSh.Cells(Last + 1, "B"))

            End If

            If Last = 1 Then
                DestSh.Cells(Last, "A").Resize(CopyRng.Rows.Count).Value = sh.Name
            Else
                 DestSh.Cells(Last + 1, "A").Resize(CopyRng.Rows.Count).Value = sh.Name
            End If

        End If
    Next

ExitTheSub:

    Application.Goto DestSh.Cells(1)
    DestSh.Columns.AutoFit

    With Application
        .ScreenUpdating = True
        .EnableEvents = True
    End With

End Sub


Public Function GetLastRow(ByVal ws As Worksheet, Optional ByVal columnNumber As Long = 1) As Long

    With ws

      GetLastRow = .Cells(.Rows.Count, columnNumber).End(xlUp).Row

    End With

End Function

Answer 3

你可以大大缩短这个时间......有很多关于在主表上获取项目的帖子，仅从昨天开始就有 4 个。

看看这个：

Dim lrSrc As Long, lrDst As Long, i As Long
For i = 1 To Sheets.Count
    If Not Sheets(i).Name = "Destination" Then
        lrSrc = Sheets(i).Cells(Sheets(i).Rows.Count, "A").End(xlUp).Row
        lrDst = Sheets("Destination").Cells(Sheets("Destination").Rows.Count, "A").End(xlUp).Row
        With Sheets(i)
            .Range(.Cells(2, "A"), .Cells(lrSrc, "B")).Copy Sheets("Destination").Range(Sheets("Destination").Cells(lrDst + 1, "B"), Sheets("Destination").Cells(lrDst + 1 + lrSrc, "C")) 'Assumes headers in first row aren't being copied
            Sheets("Destination").Range(Sheets("Destination").Cells(lrDst + 1, "A"), Sheets("Destination").Cells(lrDst + 1 + lrSrc, "A")).Value = Sheets(i).Name
        End With
    End If
 Next i

现在测试代码