VBA-调整-将数据复制到母版图纸，并在每行旁边插入图纸名称

我在这里得到了关于这个问题的帮助：

但我需要给这艘潜艇添加另一个条件

当前发生的情况是，宏将复制工作簿中所有工作表的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

Sub-third party_copysheetnameto column（）
将sh设置为工作表
将DestSh设置为工作表
持续时间一样长
暗拷贝As范围
应用
.ScreenUpdate=False
.EnableEvents=False
以
'删除工作表“摘要”（如果存在）
Application.DisplayAlerts=False
出错时继续下一步
Active工作簿。工作表（“摘要”）。删除
错误转到0
Application.DisplayAlerts=True
'添加名为“摘要”的工作表'
设置DestSh=ActiveWorkbook.Worksheets.Add
DestSh.Name=“摘要”
'循环浏览所有工作表并将数据复制到DestSh
对于ActiveWorkbook.工作表中的每个sh
如果sh.Name DestSh.Name和sh.Name“fakeSheet1”和sh.Name“fakeSheet2”，则
'查找DestSh上包含数据的最后一行
最后一行=最后一行（DestSh）
'填写要复制的范围
设置CopyRng=sh.Range（“A2”，sh.Range（“B”和Rows.count）.End（xlUp））
'测试DestSh中是否有足够的行来复制所有数据
如果Last+CopyRng.Rows.count>DestSh.Rows.count，则
MsgBox“Destsh中没有足够的行”
下地狱
如果结束
'如果您只想复制
'值或要复制所有内容请参见此宏下面的示例
复制，复制
带目标单元格（最后+1，“B”）
.Paste特殊XLPaste值
'.Paste特殊XLPaste格式
Application.CutCopyMode=False
以
这将复制A列中的图纸名称
DestSh.Cells（Last+1，“A”）.Resize（CopyRng.Rows.count）.Value=sh.Name
如果结束
下一个
退出主题：
应用程序。转到DestSh。单元格（1）
'自动调整DestSh工作表中的列宽
DestSh.Columns.AutoFit
应用
.ScreenUpdate=True
.EnableEvents=True
以
端接头
函数lastRow（sh作为工作表）
出错时继续下一步
lastRow=sh.Cells.Find（内容：=“*”_
之后：=sh.Range（“A1”）_
看：=xlPart_
LookIn:=xl公式_
搜索顺序：=xlByRows_
搜索方向：=xlPrevious_
MatchCase:=False）。行
错误转到0
端函数
函数lastCol（sh作为工作表）
出错时继续下一步
lastCol=sh.Cells.Find（内容：=“*”_
之后：=sh.Range（“A1”）_
看：=xlPart_
LookIn:=xl公式_
SearchOrder:=xlByColumns_
搜索方向：=xlPrevious_
MatchCase:=False）。列
错误转到0
端函数

这应该解决第一点——在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

Sub-third party_copysheetnameto column（）
将sh设置为工作表
将DestSh设置为工作表
持续时间一样长
暗拷贝As范围
应用
.ScreenUpdate=False
.EnableEvents=False
以
Application.DisplayAlerts=False
出错时继续下一步
Active工作簿。工作表（“摘要”）。删除
错误转到0
Application.DisplayAlerts=True
设置DestSh=ActiveWorkbook.Worksheets.Add
DestSh.Name=“摘要”
'DestSh的示例标题
DestSh.Range（“A1:C1”）.Value=数组（“一”、“二”、“三”）
对于ActiveWorkbook.工作表中的每个sh
如果sh.Name DestSh.Name那么
最后一行=最后一行（DestSh）
'根据列A中的行数调整范围，并调整大小以添加列B
设置CopyRng=sh.Range（“A2”，sh.Range（“A”和Rows.Count）。结束（xlUp））。调整大小（，2）
如果Last+CopyRng.Rows.Count>DestSh.Rows.Count，则
MsgBox“Destsh中没有足够的行”
下地狱
如果结束
复制，复制
带目标单元格（最后+1，“B”）
.Paste特殊XLPaste值
Application.CutCopyMode=False
以
DestSh.Cells（Last+1，“A”）.Resize（CopyRng.Rows.Count）.Value=sh.Name
如果结束
下一个
退出主题：
应用程序。转到DestSh。单元格（1）
DestSh.Columns.AutoFit
应用
.ScreenUpdate=True
.EnableEvents=True
以
端接头

---

关于第二个问题，您正在代码中创建工作表，因此当您开始创建工作表时，它将为空-我为一些标题添加了一行。

“（..）但我也需要对这些工作表应用相同的复制/粘贴方法。”-请指定您的问题。另外，不要发布你的全部代码，把它减少到你有问题的部分。你能设置copyRng=sh.Range（“A2”，sh.Range（“A”）和sh.Rows.Count）。结束（xlUp）。偏移量（，1））谢谢你的回复@QHarr。我看到SJR在下面的回答中也包含了您的建议。谢谢你：）谢谢@SJR。。我通信