两个工作簿，相同的工作表名称：如果工作表匹配则复制和粘贴

Question

我有两个工作簿，sheet 的名称相同（但顺序不同），我想复制一个工作簿的所有 sheet 的信息，然后粘贴该信息在其他工作簿的相应 sheet 中（匹配 sheet 名称）。我觉得这段代码是正确的，但也许有更有效或更简洁的方法来做到这一点。代码正在运行，但它显示警告，如“windows 剪贴板中有大量数据......等等......“

Sub ActualizarNoticias()
     Dim aw As Workbook
     Dim y As Workbook

Set aw = Application.ActiveWorkbook
Set y = Application.Workbooks.Open("G:\Estudios\Biblioteca\Mercado Accionario Chileno\BBDD Oficial.xlsm")


For i = 1 To aw.Sheets.Count
For j = 1 To y.Sheets.Count

If aw.Worksheets(i).Name = y.Worksheets(j).Name Then

y.Worksheets(j).Range("A3").Copy
aw.Worksheets(i).Range("A100").PasteSpecial
End If

Next j
Next i

y.close
' ActualizarNoticias Macro
'
'
End Sub

Answer 1

我不确定你打算复制多少数据，或者你想复制到目标工作簿中的哪个位置，但是你发布的代码只复制了一个单元格（A3）并将其复制到单元格中的目标工作簿中A100。我收集你的代码只是一个例子，因为复制单个单元格肯定不会出现警告。获得您的实际范围和准确的警告消息会有所帮助，但正如您所说，它正在起作用。当您运行代码或退出工作簿时，您是否收到消息？如果是后者（正如我怀疑的那样），那么您只需清除代码末尾的剪贴板即可：

    Application.CutCopyMode = False

你也可以用小技巧消除第二个循环：

    Set sh = Nothing
    On Error Resume Next
    Set sh = y.Worksheets(aw.Worksheets(i).Name)
    On Error GoTo 0
    If TypeName(sh) <> "Nothing" Then
        ....
    End If

我的整个子程序如下所示：

Sub CopyWorkbook()
    Dim aw As Workbook
    Dim y As Workbook
    Dim sh As Worksheet

    Set aw = Application.ActiveWorkbook
    Set y = Application.Workbooks.Open("C:\work\fusion\expenseTypes.xls.xlsx")

    For i = 1 To aw.Sheets.Count
        Set sh = Nothing
        On Error Resume Next
        Set sh = y.Worksheets(aw.Worksheets(i).Name)
        On Error GoTo 0
        If TypeName(sh) <> "Nothing" Then
            sh.Range("A:C").Copy aw.Worksheets(i).Range("A1")
        End If
    Next i
    Application.CutCopyMode = False
End Sub

我认为这是最有效的方法。我上面的示例代码复制了整个列（A 到 C），它保留了列格式，因此无需重新调整新工作簿的列宽。

两个工作簿，相同的工作表名称：如果工作表匹配则复制和粘贴

Two workbooks, Same Sheets Names: Copy and Paste if Sheets are matched

excel

vba

if-statement

worksheet

match