Zwei Arbeitsmappen, gleiche Blätter Namen: Kopieren und Einfügen, wenn Tabellen übereinstimmen

Question

Ich habe zwei Arbeitsmappen, mit demselben Blattnamen (aber in anderer Reihenfolge), und ich möchte Informationen von allen Blättern eines Arbeitsmappe kopieren, und Einfügen dieser Information in das entsprechende Blatt der anderen Arbeitsmappe (übereinstimmende Blattnamen). Ich habe das Gefühl, dass dieser Code auf dem richtigen Weg ist, aber vielleicht gibt es einen effizienteren oder saubereren Weg, dies zu tun. Code funktioniert, aber es sagt, eine Warnung wie „es gibt eine große Menge von Daten in der Zwischenablage ... etc ...“

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

Ich bin nicht sicher, wie viele Daten Sie kopieren möchten, oder wo in der Zielarbeitsmappe, in die Sie kopieren möchten, aber der von Ihnen gepostete Code kopiert nur eine Zelle (A3) und kopiert sie in die Zielarbeitsmappe in Zelle A100. Ich nehme an, Ihr Code ist nur ein Beispiel, denn sicherlich würde die Warnung nicht zum Kopieren einer einzelnen Zelle kommen. Es würde helfen, Ihre tatsächlichen Bereiche und genaue Warnmeldung zu haben, aber wie Sie gesagt haben, es funktioniert. Erhalten Sie die Nachricht, wenn Sie den Code ausführen oder wenn Sie die Arbeitsmappe beenden? Wenn letzteres (wie ich vermute), dann können Sie einfach die Zwischenablage am Ende des Codes löschen:

Application.CutCopyMode = False 

Sie können auch die zweite Schleife mit einem kleinen Tricks beseitigen:

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 

Meine Das gesamte Unterprogramm sieht folgendermaßen aus:

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 

Ich denke, dies ist der effizienteste Weg, dies zu tun. Der obige Beispielcode kopiert ganze Spalten (A bis C), wodurch die Spaltenformatierung beibehalten wird. Daher ist es nicht erforderlich, die neue Arbeitsmappe für die Spaltenbreite neu anzupassen.