VBA - Vergleichen und Kopieren | HERBERS Excel Forum

Forumthread: VBA - Vergleichen und Kopieren

VBA - Vergleichen und Kopieren

04.08.2015 13:06:45

Michael

Hallo zusammen,
ich verzweifle hier gerade an einem Code.
Problemstellung:
Ich möchte aus einer Quelldatei Werte in bestimmten Zellen aus einer Zeile in eine Zieldatei kopieren. Das funktioniert schonmal ganz gut. Ich brauche aber eine Anpassung des Codes dahingehend das erst geprüft wird ob die gleichen Werte bereits in beiden Tabellen enthalten sind. Wenn ja soll nicht kopiert werden, ansonsten nur die die noch nicht in der Zieldatei enthalten sind.
Ich habe mal die beiden Beispieldateien angehängt. So soll in der Quelldatei in der Spalte D (Nr.) auf Übereinstimmung in der Zieldatei Spalte A50 bis A64 überprüft werden. Eine Suche im Netz ergab bisher folgenden vielleicht am besten dazu passenden Code. Jedoch komme ich da ab einer bestimmten Stelle nicht mehr weiter:

Sub Import_2()
Dim wkb As Workbook
Dim wkb1 As Workbook
Dim wks As Worksheet
Dim wks1 As Worksheet
Dim rng As Range
Dim iRow As Integer
Dim i
Application.ScreenUpdating = False
On Error Resume Next
On Error GoTo 0
Set wkb = Workbooks("Quelle.xls")
Set wkb1 = ThisWorkbook
wkb1.Activate
Set wks = wkb.Worksheets("Test")
Set wks1 = wkb1.Worksheets("Import")
anz = wks.Cells(200, 4).End(xlUp).Row
'   anz1 = Range? 'Von A50:A64
For z = 3 To anz1
suchwert = wks1.Cells(z, 1)
With wks.Range("a2:a" & anz)
Set c = .Find(suchwert, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
For s = 2 To 11
wks.Cells(c.Row, s) = wks1.Cells(z, s)
Next
Else
For s = 1 To 11
wks.Cells(anz + 1, s) = wks1.Cells(z, s)
Next
anz = wks.Cells(200, 4).End(xlUp).Row
End If
End With
Next
Application.ScreenUpdating = True
End Sub

Wie gesagt, das kopieren zwischen den beiden Tabellen funktioniert wunderbar (Makro in der Zieldatei). Da sich die Quelldatei jeden Tag ändert und ich die Werte in die Zieldatei exportieren will wenn bestimmte Bedingungen erfüllt sind, brauche ich jedoch eine Art Sicherheitsnetz wo quasi die Werte in der Zieldatei nicht mehr überschrieben werden können.
Ich hoffe ich konnte mein Problem ansatzweise gut erläutern. Über jede Hilfe bin ich dankbar.
Gruß
Michael
https://www.herber.de/bbs/user/99321.xlsm
https://www.herber.de/bbs/user/99322.xls

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Warum neuer Thread?

04.08.2015 15:39:38

Frank
AW: Warum neuer Thread?

04.08.2015 16:26:45

Michael
Einfach per Schleife abfragen

05.08.2015 15:07:39

Frank
AW: Einfach per Schleife abfragen

05.08.2015 15:37:21

Michael

Warum neuer Thread?

04.08.2015 15:39:38

Frank

Siehe: https://www.herber.de/forum/messages/1440036.html
Ausserdem sind solche Aussagen: Jedoch komme ich da ab einer bestimmten Stelle nicht mehr weiter nicht eben hilfreich.
Formuliere hier mal aus, wobei Du nicht weiterkommst. Eine Fehlermeldung? Wird das falsche kopiert?
Grüsse,
Frank

AW: Warum neuer Thread?

04.08.2015 16:26:45

Michael

Der alte Thread ist so weit unten, ich wusste nicht ob das noch jemand mitbekommt und ich hab das ganze hier noch erweitert damit es hoffentlich verständlicher ist.
Wie bereits erwähnt habe ich ein Makro mit dem ich die Daten aus der Quell- in die Zieldatei nach Bedingungen kopiere.

        'Bedingungen abfragen
If IsNumeric(oSourceSheet.Cells(z, lIFCOL1).Value) = True Then
If CDbl(oSourceSheet.Cells(z, lIFCOL1).Value) > 0 And _
(UCase(Trim(CStr(oSourceSheet.Cells(z, lIFCOL2)))) = "FALSE" Or _
Trim(CStr(oSourceSheet.Cells(z, lIFCOL2))) = "") Then
oTargetSheet.Cells(zInsert, 1) = oSourceSheet.Cells(z, 4)
oTargetSheet.Cells(zInsert, 3) = oSourceSheet.Cells(z, 6)
oTargetSheet.Cells(zInsert, 4) = oSourceSheet.Cells(z, 7)
oTargetSheet.Cells(zInsert, 6) = oSourceSheet.Cells(z, 17)
oTargetSheet.Cells(zInsert, 7) = oSourceSheet.Cells(z, 15)
oTargetSheet.Cells(zInsert, 8) = oSourceSheet.Cells(z, 31)
'Einfügezeile erhöhen
zInsert = zInsert + 1

Was das Makro jedoch nicht macht ist, dass vorher in der Zieldatei geprüft wird ob ein Wert in der Range A50:A64 bereits vorkommt. Die Spalte A ist deshalb gewählt weil dieser Wert nur einmal in der Quelldatei vorkommen kann. Daher soll anhand dieses Wertes überprüft werden ob der gleiche Wert in den beiden Tabellen vorkommt. Wenn ja sollen die entsprechenden Zellen aus der Zeile nicht kopiert werden sondern der nächste Wert auf Übereinstimmung überprüft werden. Dh. im Endeffekt sollen nur Werte kopiert werden die noch nicht in der Zieldatei enthalten sind.
Ich hab dazu viel recherchiert aber nichts gefunden was ohne große Anpassung umsetzbar wäre und da hört meine VBA Kenntnis auf.

Sub Import_2()
Dim wkb As Workbook
Dim wkb1 As Workbook
Dim wks As Worksheet
Dim wks1 As Worksheet
Dim rng As Range
Dim iRow As Integer
Dim i
Application.ScreenUpdating = False
On Error Resume Next
On Error GoTo 0
Set wkb = Workbooks("Quelle.xls")
Set wkb1 = ThisWorkbook
wkb1.Activate
Set wks = wkb.Worksheets("Test")
Set wks1 = wkb1.Worksheets("Import")
anz = wks.Cells(200, 4).End(xlUp).Row
'   anz1 = Range? 'Von A50:A64
For z = 3 To anz1
suchwert = wks1.Cells(z, 1)
With wks.Range("a2:a" & anz)
Set c = .Find(suchwert, LookIn:=xlValues, LookAt:=xlWhole)
If Not c Is Nothing Then
For s = 2 To 11
wks.Cells(c.Row, s) = wks1.Cells(z, s)
Next
Else
For s = 1 To 11
wks.Cells(anz + 1, s) = wks1.Cells(z, s)
Next
anz = wks.Cells(200, 4).End(xlUp).Row
End If
End With
Next
Application.ScreenUpdating = True
End Sub

Diesen Code hatte ich zB gefunden und versucht ihn an meine Bedürfnisse anzupassen aber ich weiß zB nicht wie ich die Bereiche in den beiden Mappen deklarieren soll. In der Zieldatei ist es immer A50:A64, also der Bereich wo die Werte untersucht werden sollen. In der Quelldatei ist der UsedRange aber variabel, d.h. er ändert sich jedoch täglich und müsste erst ermittelt werden.Dabei handelt es sich jedoch immer um die Spalte D die untersucht werden soll. Also Spalte A mit Spalte D vergleichen. Wenn Übereinstimmung dann nichts und nächste Zeile, ansonsten die Zellen kopieren die ich im Code vorher angegeben hab.
Summa summarum, zu dem bereits existierenden Code mit dem ich bereits erfolgreich kopiere brauche ich eine vorgeschaltete Funktion die die Werte in beiden Mappen miteinander vergleicht damit bereits existierende Einträge in der Zieldatei nicht überschrieben werden. Der Sinn des Ganzen, wenn ich in der Zieldatei kleine Anpassungen vornehme möchte ich nicht das das Ganze wieder überschrieben wird.
Ich hoffe das war etwas ausführlicher.
Gruß
Michael

Einfach per Schleife abfragen

05.08.2015 15:07:39

Frank

Hallo Michael,
dann schliesse doch das gesamte Kopieren der Werte in eine IF-THEN-Prozedur ein.
In etwa so:

QW=Sheets("Quelle").cells(i,1).value
Z1=0
for k=50 to 64
if QW=Sheets("Ziel").cells(k,1).value then Z1=Z1+1
next
if Z1

Sheets("Quelle").cells(i,1).value: Hier gehe ich davon aus, dass Du mittels einer Schleife (Laufvariable i) jede Zeile Deiner Quelldaten einzeln prüfst.
Kleiner Tipp: Mit einer Beispielmappe machst Du's willigen Helfern leichter.
Grüsse,
Frank

AW: Einfach per Schleife abfragen

05.08.2015 15:37:21

Michael

Hallo Frank,
Danke schonmal für deine Mühe. Eine Beispielmappe bzw. sogar beide (Quell- und Zieldatei) sind im ersten Post angehängt. Ich versuche aber schonmal deinen Tipp zu beherzigen.
Danke und Gruß
Michael

Infobox / Tutorial

Werte vergleichen und kopieren in Excel VBA

Schritt-für-Schritt-Anleitung
Häufige Fehler und Lösungen
Alternative Methoden
Praktische Beispiele
Tipps für Profis
FAQ: Häufige Fragen

Schritt-für-Schritt-Anleitung

Öffne deine Excel-Dateien: Stelle sicher, dass sowohl die Quelldatei als auch die Zieldatei geöffnet sind.
Erstelle ein neues VBA-Modul:
- Öffne den VBA-Editor mit ALT + F11.
- Klicke mit der rechten Maustaste auf dein Projekt und wähle Einfügen > Modul.

Füge den VBA-Code ein: Nutze den folgenden angepassten Code, um die Werte aus der Quelldatei in die Zieldatei zu vergleichen und zu übertragen.

Sub Import_2()
   Dim wkb As Workbook
   Dim wkb1 As Workbook
   Dim wks As Worksheet
   Dim wks1 As Worksheet
   Dim iRow As Integer
   Dim anz As Long
   Dim anz1 As Long

   Application.ScreenUpdating = False
   Set wkb = Workbooks("Quelle.xls")
   Set wkb1 = ThisWorkbook
   Set wks = wkb.Worksheets("Test")
   Set wks1 = wkb1.Worksheets("Import")

   anz = wks.Cells(wks.Rows.Count, 4).End(xlUp).Row
   anz1 = 64 ' A50 bis A64

   For z = 3 To anz
       Dim suchwert As String
       suchwert = wks1.Cells(z, 1).Value
       Dim exists As Boolean
       exists = False

       ' Prüfung auf Übereinstimmung in der Zieldatei
       For k = 50 To 64
           If wks1.Cells(k, 1).Value = suchwert Then
               exists = True
               Exit For
           End If
       Next k

       ' Werte kopieren, wenn nicht vorhanden
       If Not exists Then
           wks.Cells(anz + 1, 1).Value = suchwert
           ' Weitere Zellen hier kopieren...
           anz = anz + 1
       End If
   Next z

   Application.ScreenUpdating = True
End Sub

Häufige Fehler und Lösungen

Fehler: "Objekt nicht gefunden": Stelle sicher, dass die Arbeitsblätter in deinem Code korrekt benannt sind und die Quelldatei geöffnet ist.
Fehler: Werte werden nicht kopiert: Überprüfe, ob die Bedingungen für das Kopieren der Werte im Code korrekt gesetzt sind.
VBA läuft nicht: Prüfe, ob Makros in deinen Excel-Einstellungen aktiviert sind.

Alternative Methoden

Wenn du keine VBA-Lösungen verwenden möchtest, kannst du auch Excel-Funktionen wie SVERWEIS oder WENN nutzen, um Werte zu vergleichen. Diese Methoden sind jedoch nicht so flexibel wie der VBA-Ansatz und bieten nicht die gleiche Automatisierung.

Praktische Beispiele

Hier ist ein einfaches Beispiel, wie du den VBA-Code anpassen kannst, um mehrere Zellen zu kopieren:

wks.Cells(anz + 1, 2).Value = wks1.Cells(z, 2).Value ' Kopiere aus Spalte B
wks.Cells(anz + 1, 3).Value = wks1.Cells(z, 3).Value ' Kopiere aus Spalte C

Du kannst die Spalten nach Bedarf anpassen.

Tipps für Profis

Speichere deine Arbeit regelmäßig: Wenn du mit VBA arbeitest, kann es zu Fehlern kommen, die Excel zum Absturz bringen.
Testen in einer Kopie deiner Datei: Arbeite immer in einer Testversion deiner Datei, um Datenverlust zu vermeiden.
Nutze das Debugging: Verwende F8, um den Code Schritt für Schritt auszuführen und zu verstehen, wo es Probleme gibt.

FAQ: Häufige Fragen

1. Wie kann ich den Code an meine eigenen Daten anpassen? Du kannst den Bereich und die Spalten im Code anpassen, indem du die entsprechenden Indizes änderst.

2. Was mache ich, wenn ich mehrere Quelldateien habe? Du kannst eine Schleife einfügen, die durch alle Quelldateien iteriert und den Vergleich entsprechend anpasst.

3. Welche Excel-Version wird benötigt? Der bereitgestellte VBA-Code sollte mit Excel 2010 und höher funktionieren.

Beliebteste Forumthreads (12 Monate)

VBA - Vergleichen und Kopieren

Forumthread: VBA - Vergleichen und Kopieren

4 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu diesem und ähnlichen Themen

Infobox / Tutorial

Werte vergleichen und kopieren in Excel VBA

Schritt-für-Schritt-Anleitung

Häufige Fehler und Lösungen

Alternative Methoden

Praktische Beispiele

Tipps für Profis

FAQ: Häufige Fragen

Beliebteste Forumthreads (12 Monate)

4
Beiträge zum Forumthread

Beiträge zu diesem Forumthread