ich habe mal wieder ein Problem.
Ich habe das u.g. Makro in den tiefen von Herber.de gefunden.
Das Makro sollte eigentlich Daten aus der Quelle.xlsx nach Ziel.xlsm vergleichen und übertragen. Ich habe einiges angepasst. Das Makro läuft mit Excel 2013 durch, jedoch werden keine Daten übertragen. Das Makro sollte in der Ziel.xlsm sein da sich die Quelle.xlsx immer wieder ändert.
Formate die mit einem sverweis später bearbeitet werden: 12345678, ZS123456 und 00123456787
Funktion des Makros:
Quelle.xlsx, Daten A2:AC40.000 (Variabel)
In Spalte A stehen die Werte zum Vergleichen.
Ziel.xlsm ab A2 mit Quelle.xlsx alle Zellen 1zu1 vergleichen und Spaltenweise (z.B.: A, B, H, K) nach Ziel.xlsm übernehmen.
Fehlende Daten in Ziel.xlsm Spalte A in der eintragen.
Neue Daten müssen dann nach dem letzten Eintrag in Ziel.xlsm Spalte A zugefügt werden.
Es dürfen keine Daten gelöscht werden.
zusätzlicher Wunsch:
Bei Änderungen der Daten in Ziel.xlsm, diese zellenweise Orange markieren.
Ich hoffe ich habe das einigermaßen verständlich geschrieben.
Die Beschreibungen im Makro stimmen nicht ganz.
Mit freundlichen Grüßen
Manfred
Sub Datenabgleich_01()
'Daten aus zwei Tabellen abgleichen per Schlüsselspalte
Dim wbQuelle As Workbook, wksQuelle As Worksheet, vAuswahl
Dim wbZiel As Workbook, wksZiel As Worksheet
Dim varSchluessel, lSpalteSchluessel As Long
Dim Zelle As Range, rBereich As Range
Dim ZeileQuelle As Long, ZeileZiel As Long
'Quelldatei auswählen
vAuswahl = Application.GetOpenFilename( _
FileFilter:="Excel (*.xls;*.xlsx;*.xlsb;*.xlsm),*.xls;*.xlsx;*.xlsb;*.xlsm", _
Title:="Bitte Datei mit Quelldaten auswählen")
If vAuswahl = False Then GoTo Beenden
'Tabelle in der Inhalte eingetragen werden sollen
'Set wbZiel = ActiveWorkbook ' oder = Workbooks("Ziel.xlsm") 'Name anpassen!
Set wbZiel = Workbooks("Ziel.xlsm") 'Name anpassen!
Set wksZiel = wbZiel.Worksheets("Tabelle1") 'Name - anpassen
'Nr. der Schlüsselspalte in Zieldatei
lSpalteSchluessel = 1 'ggf Anpassen
With wksZiel
'Letzte Datenzeile in Zieltabelle Spalet A
ZeileZiel = .Cells(.Rows.Count, lSpalteSchluessel).End(xlUp).Row
'Beich mit ID-Nummern im Zielblatt
Set rBereich = .Range(.Cells(2, lSpalteSchluessel), .Cells(ZeileZiel, lSpalteSchluessel))
End With
'Tabelle mit ggf. neuen Daten
Set wbQuelle = Workbooks.Open(Filename:=vAuswahl, ReadOnly:=True)
Set wksQuelle = wbQuelle.Worksheets("Tabelle1") 'Export
Application.ScreenUpdating = False
With wksQuelle
lSpalteSchluessel = 1 'Spalte mit ID-Code in Quelldatei
For ZeileQuelle = 2 To .Cells(.Rows.Count, lSpalteSchluessel).End(xlUp).Row
'Such-Werte aus Zeile in Zieltabelle einlesen
varSchluessel = .Cells(ZeileQuelle, lSpalteSchluessel)
'Name in Bereich mit ID-Code in Zieltabelle suchen
Set Zelle = rBereich.Find(what:=varSchluessel, _
LookIn:=xlValues, lookat:=xlWhole)
If Zelle Is Nothing Then 'Code in Zieldatei nicht vorhanden
'do nothing - keine Daten übertragen
Else
'Daten in Zieltabelle übertragen
ZeileZiel = Zelle.Row
wksZiel.Cells(ZeileZiel, 1) = .Cells(ZeileQuelle, 1) 'Spalte A in A eintragen
wksZiel.Cells(ZeileZiel, 2) = .Cells(ZeileQuelle, 2) 'Spalte B in B eintragen
wksZiel.Cells(ZeileZiel, 3) = .Cells(ZeileQuelle, 8) 'Spalte H in C eintragen
'usw
End If
Next
End With
'Quelldatei wieder schließen
wbQuelle.Close savechanges:=False
Application.ScreenUpdating = True
MsgBox "Fertig!", vbInformation + vbOKOnly, "Datenabgleich"
Beenden:
Set wbQuelle = Nothing: Set wbZiel = Nothing: Set wksQuelle = Nothing: Set wksZiel = Nothing
Set Zelle = Nothing: Set rBereich = Nothing
End Sub