Question

我在这里收到了这个问题的帮助：

Copy Data to Master Sheet and Insert Sheet Name Next to Each Row

但是我需要为这个子添加另一个条件。

目前发生的情况是，宏将复制工作簿中所有工作表的A列和B列的数据，并将其粘贴到摘要表的B列和C列中，而A列中的数据将是从中复制数据的工作表。

但是，有两个表没有B列中的数据，因此，唯一复制的数据是第2行。在下面的宏中，我添加了一个查找这两个工作表名称的条件并且它将它们从宏中排除，但我也需要对这些表格应用相同的复制/粘贴方法。

另外一个问题，即假设不是太大的问题，是当复制第一张纸时，它会删除摘要表上的标题，但是当复制每张其他纸张时，它会粘贴在最后一个包含数据的纸张下面在它..

以下是代码：

Sub ThirdParty_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 "Summary" if it exist
    Application.DisplayAlerts = False
    On Error Resume Next
    ActiveWorkbook.Worksheets("Summary").Delete
    On Error GoTo 0
    Application.DisplayAlerts = True

    'Add a worksheet with the name "Summary"
    Set DestSh = ActiveWorkbook.Worksheets.Add
    DestSh.Name = "Summary"

    'loop through all worksheets and copy the data to the DestSh
    For Each sh In ActiveWorkbook.Worksheets

        If sh.Name <> DestSh.Name And sh.Name <> "fakeSheet1" And sh.Name <> "fakeSheet2" 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("A2", sh.Range("B" & Rows.count).End(xlUp))

            '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

            This will copy the sheet name in the A 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

这应该解决第一点 - 在CopyRng行上添加注释。

Sub ThirdParty_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("Summary").Delete
On Error GoTo 0
Application.DisplayAlerts = True

Set DestSh = ActiveWorkbook.Worksheets.Add
DestSh.Name = "Summary"
'Sample headers for DestSh
DestSh.Range("A1:C1").Value = Array("One", "Two", "Three")

For Each sh In ActiveWorkbook.Worksheets
    If sh.Name <> DestSh.Name Then
        Last = lastRow(DestSh)
        'Base the range on the number of rows in col A and resize to add col B
        Set CopyRng = sh.Range("A2", sh.Range("A" & Rows.Count).End(xlUp)).Resize(, 2)
        If Last + CopyRng.Rows.Count > DestSh.Rows.Count Then
            MsgBox "There are not enough rows in the Destsh"
            GoTo ExitTheSub
        End If
        CopyRng.Copy
        With DestSh.Cells(Last + 1, "B")
            .PasteSpecial xlPasteValues
            Application.CutCopyMode = False
        End With
        DestSh.Cells(Last + 1, "A").Resize(CopyRng.Rows.Count).Value = sh.Name
    End If
Next

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

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

End Sub

关于你的第二个问题，你是在代码中创建工作表，所以当你启动时它将是空白的 - 我为一些标题添加了一行。

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

1 个答案: