AW: Zwei verschiedene Tabellen vergleichen
13.09.2016 16:19:01
Michael
Hi,
in diesem Fall haben beide Tabellen die gleichen IDs, so daß im Prinzip ALLE übernommen werden würden - richtig?
Also, versuch mal das hier:
Option Explicit
Sub machen()
Dim od As Object, it
Dim neuSh As Worksheet
Dim wbPfad As String
Dim doc, id
Dim maxz&, z&
wbPfad = ActiveWorkbook.Path
' 1. neues Blatt anlegen
Sheets("sheet1").Copy after:=Sheets(Sheets.Count)
Set neuSh = ActiveSheet
' 2. zweite Datei öffnen, einlesen & schließen
Workbooks.Open Filename:="C:\A_Forum_DL\FabiM_108127.xlsx", ReadOnly:=True
' hier Dein Pfad usw. ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
maxz = Range("G" & Rows.Count).End(xlUp).Row
doc = Range("D2:D" & maxz)
id = Range("G2:G" & maxz)
ActiveWorkbook.Close savechanges:=False
' 3. Daten in "Dictionary" schaufeln
' neuSh.Range("H3").Resize(UBound(id), 1) = id ' das war nur zum Test
Set od = CreateObject("scripting.dictionary")
For z = 1 To UBound(id): od(id(z, 1)) = doc(z, 1): Next
' 4. Spalte G in neuer Tabelle mit "Dok" aus Dictionary füllen
maxz = neuSh.Range("D" & neuSh.Rows.Count).End(xlUp).Row
id = neuSh.Range("D2:D" & maxz)
doc = neuSh.Range("G2:G" & maxz)
For z = 1 To UBound(id)
If od.exists(id(z, 1)) Then doc(z, 1) = od(id(z, 1)) Else doc(z, 1) = ""
Next
neuSh.Range("G2").Resize(UBound(id), 1) = doc
' 5. hier ggf. nach Spalte G sortieren, damit leere am Stück gelöscht werden können
' 6. neuSh in neue Datei schreiben
neuSh.Move
ActiveWorkbook.SaveAs Filename:=wbPfad & "\" & "FabiM_" & CStr(Timer) & ".xlsx", _
FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
ActiveWorkbook.Close
End Sub
Datei: https://www.herber.de/bbs/user/108144.xlsm
Ich habe das Makro aus Zeitgründen in die "erste" Datei gepackt; es ist noch nicht ganz so, wie Du es Dir vorstellst, aber es ist zu heiß zum Denken; vielleicht macht es jemand anderes gar fertig.
Schöne Grüße,
Michael