Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1656to1660
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

Werte vergleichen und ergänzen

Werte vergleichen und ergänzen
09.11.2018 13:37:57
Vic
Hallo Excelfreunde,
ich kann meinen Knoten gerade nicht lösen - ich möchte aus (Arbeitsmappe 1 - Tabelle1 - Spalte B bis letzte Zeile) Werte vergleichen mit (Arbeitsmappe 2 - Tabelle1 - Spalte B bis letzte Zeile). Ist der Wert nicht vorhanden, soll er in die erste freie Zeile von Arbeitsmappe 2 - Tabelle 1 angefügt werden.
Das funktioniert mit meinem Code nicht: Sind in Arbeitsmappe 2 mehr Werte als in Arbeitsmappe 1 _ werden die kompletten Werte aus Arbeitsmappe 1 erneut ans Ende in Arbeitsmappe 2 gestellt. Gleiches gilt bei Veränderung der Reihenfolge in der Quellmappe.

Public Sub Uebertrag()
'Plan öffnen
Application.ScreenUpdating = False
Const LW = "C:\"
Const Pfad = "C:\Daten\"
Const Datei = "Mappe1.xlsx"
ChDrive LW
ChDir Pfad
Workbooks.Open Datei
Dim letzteQ As Long
Dim letzteZ As Long
Dim wksQ As Worksheet
Dim wksZ As Worksheet
Set wksQ = Workbooks("Mappe1.xlsx").Sheets(1)
Set wksZ = Workbooks("Sammlung.xlsm").Sheets(1)
Dim zeile As Long, Suchzeile As Long
'letzte Zeile in Quelle und Ziel ermitteln
letzteQ = wksQ.Cells(wksQ.Rows.Count, 2).End(xlUp).Row
letzteZ = wksZ.Cells(wksZ.Rows.Count, 2).End(xlUp).Row + 1
'Spalten durchlaufen und bei Treffer nächste Zeile
For zeile = 2 To letzteZ
For Suchzeile = 2 To letzteQ
If wksQ.Cells(Suchzeile, 2) = wksZ.Cells(zeile, 2) Then
zeile = zeile + 1
Else
'wenn nicht vorhanden - Wert ans Ende in Ziel
wksZ.Cells(letzteZ, 2) = wksQ.Cells(Suchzeile, 2)
letzteZ = letzteZ + 1
End If
Next Suchzeile
Next zeile
Set wksQ = Nothing
Set wksZ = Nothing
'Quelldatei schließen
Workbooks(Datei).Close
Application.ScreenUpdating = True
End Sub
Könnt ihr mir da behilflich sein? Mit der .find-Methode hatte ich auch probiert - bin aber an meine Grenzen gestoßen.
Gruß Vic

9
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Werte vergleichen und ergänzen
09.11.2018 14:22:13
Zwenn
Hallo Vic,
Du darfst die beiden Schleifenzähler nicht manuell verändern. Sie werden automatisch durch die For-Schleife hochgezählt. So wie Du es machst überspringst Du jede Menge Zeilen. Also die beiden Zeilen zeile = zeile + 1 und letzteZ = letzteZ + 1 ersatzlos löschen.
Weiterhin musst Du die Schleifen genau andersrum anordnen, wenn ich es richtig verstanden habe. Du nimmst erst einen Wert aus der Liste, die Du ergänzen willst. Ist diese kürzer als die Liste, in der die Verleichswerte stehen, werden niemals alle Werte verglichen. Durch das Wegfallen der Scheifenzählermanipulation vereinfacht sich außerdem der If-Ausdruck in der inneren Schleife. Diese kann zusätzlich abgebrochen werden, wenn der Wert gefunden wurde. Das spart Zeit. Wenn Deine Listen sehr lang sind, ist das aber trotzdem noch nicht richtig performant.
Ich denke der Codeabschnitt sollte so aussehen (ungeprüft):

For Suchzeile = 2 To letzteQ
For zeile = 2 To letzteZ
If wksQ.Cells(Suchzeile, 2)  wksZ.Cells(zeile, 2) Then
'wenn nicht vorhanden:
' - Wert ans Ende in Ziel
' - und inneren Schleifenlauf beenden
wksZ.Cells(letzteZ, 2) = wksQ.Cells(Suchzeile, 2)
Exit For
End If
Next zeile
Next Suchzeile

Ich hoffe da ist jetzt kein Denkfehler drin. Als Entschuldigung hätte ich sonst die Erkältung, an der ich noch rumlaboriere ;-)
Viele Grüße,
Zwenn
Anzeige
AW: Werte vergleichen und ergänzen
09.11.2018 14:30:25
Zwenn
Hi,
ich nochmal. Meine Lösung funktioniert so auch nicht richtig. Die Variable letzteZ beschreibt immer die gleiche Zeile. Deshalb wird die Liste nicht länger Du brauchst eine weitere Variable, die die Zeilen, in die geschrieben wird weiter hochzählt.
In etwa so:

DIM schreibZeileZ as long
schreibZeileZ = letzteZ
For Suchzeile = 2 To letzteQ
For zeile = 2 To letzteZ
If wksQ.Cells(Suchzeile, 2)  wksZ.Cells(zeile, 2) Then
'wenn nicht vorhanden:
' - Wert ans Ende in Ziel
' - und inneren Schleifenlauf beenden
wksZ.Cells(schreibZeileZ, 2) = wksQ.Cells(Suchzeile, 2)
schreibZeileZ = schreibZeileZ + 1
Exit For
End If
Next zeile
Next Suchzeile
Noch immer ungetestet und ohne Gewähr.
Viele Grüße,
Zwenn
Anzeige
AW: Werte vergleichen und ergänzen
09.11.2018 14:28:31
Werner
Hallo,
wieso überhaupt zwei Schleifen?
Eine Schleife über die "Suchbegriffe" und mit CountIf prüfen, ob der Suchbegriff vorhanden ist oder nicht.
Public Sub Uebertrag()
Dim loLetzteQ As Long
Dim raBereich As Range, raZelle As Range
Dim wksQ As Worksheet, wksZ As Worksheet
Application.ScreenUpdating = False
Const LW = "C:\"
Const Pfad = "C:\Daten\"
Const Datei = "Mappe1.xlsx"
ChDrive LW
ChDir Pfad
Workbooks.Open Datei
Set wksQ = Workbooks("Mappe1.xlsx").Sheets(1)
Set wksZ = Workbooks("Sammlung.xlsm").Sheets(1)
With wksQ
loLetzteQ = .Cells(.Rows.Count, 2).End(xlUp).Row
Set raBereich = .Range(.Cells(1, 2), .Cells(loLetzteQ, 2))
For Each raZelle In raBereich
If WorksheetFunction.CountIf(wsZ.Columns(2), raZelle) = 0 Then
With wksZ
.Cells(.Cells(.Rows.Count, 2).End(xlUp).Offset(1).Row, 2) = raZelle
End With
End If
Next raZelle
End With
Set wksQ = Nothing: Set wksZ = Nothing
Workbooks(Datei).Close
End Sub
Ist aber ungetestet.
Gruß Werner
Anzeige
Danke euch beiden...kurze Nachfrage
09.11.2018 14:56:34
Vic
...die Lösung von Werner funktioniert wie gewünscht und ist für mich nachvollziehbar sinnvoller als mein Ansatz. Eine Folgefrage an dich Werner zur Schreibweise
Set wksQ = Nothing: Set wksZ = Nothing
Was genau passiert da im Gegensatz zu
Set wksQ = Nothing
Set wksZ = Nothing
Die Funktion des Doppelpunkt als Trennzeichen kenne ich bisher gar nicht. Warum diese Schreibweise?
Vic
AW: Danke euch beiden...kurze Nachfrage
09.11.2018 15:05:52
Zwenn
Hi Vic,
die Lösung von Werner ist auch besser :-) Der Doppelpunkt dient als Befehlstrennung, wenn man mehrere Befehle in eine Zeile schreibt, die normalerweise auf mehrere Zeilen aufgeteilt werden. Er erstezt sozusagen den Zeilenumbruch. Manchmal macht das den Code übersichtlicher, wird aber eher selten verwendet soweit ich weiß.
Viele Grüße,
Zwenn
Anzeige
Gerne u. Danke für die Rückmeldung.
09.11.2018 15:07:47
Werner
Hallo Vic,
und eine Antwort auf deine Frage hast du ja schon.
Gruß Werner
Verstehe, Danke noch mal o.w.T.
09.11.2018 15:18:46
Vic
AW: Verstehe, Danke noch mal o.w.T.
11.11.2018 12:50:41
Werner
Hallo Vic,
falls du hier noch mal rein schaust. Hier noch eine Lösung ganz ohne Schleife. Dürfte, je nach Datenmenge auf alle Fälle wesentlich schneller sein als die Lösung mit Schleife.
Hier werden einfach alle Daten von Tabelle1 nach Tabelle2 kopiert und dann mit RemoveDuplicates die doppelten in Tabelle2 wieder entfernt.
Public Sub ohne_Doppler()
Dim wsQ As Worksheet, wsZ As Worksheet
Set wsQ = ThisWorkbook.Worksheets("Tabelle1")
Set wsZ = ThisWorkbook.Worksheets("Tabelle2")
Application.ScreenUpdating = False
wsQ.Range(wsQ.Cells(1, 2), wsQ.Cells(wsQ.Cells(wsQ.Rows.Count, 2).End(xlUp).Row, 2)).Copy
wsZ.Cells(wsZ.Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
wsZ.Columns(2).RemoveDuplicates Columns:=1, Header:=xlNo
Set wsQ = Nothing: Set wsZ = Nothing
End Sub
Gruß Werner
Anzeige
andere Lösung
11.11.2018 13:03:44
Werner
Hallo Vic,
hier nochmal der komplette Code, mit den Constanten
Public Sub ohne_Doppler()
Dim wsQ As Worksheet, wsZ As Worksheet
Const LW = "C:\"
Const Pfad = "C:\Daten\"
Const Datei = "Mappe1.xlsx"
ChDrive LW
ChDir Pfad
Workbooks.Open Datei
Set wsQ = ThisWorkbook.Worksheets("Tabelle1")
Set wsZ = ThisWorkbook.Worksheets("Tabelle2")
Application.ScreenUpdating = False
wsQ.Range(wsQ.Cells(1, 2), wsQ.Cells(wsQ.Cells(wsQ.Rows.Count, 2).End(xlUp).Row, 2)).Copy
wsZ.Cells(wsZ.Rows.Count, 2).End(xlUp).Offset(1).PasteSpecial Paste:=xlPasteValues
Application.CutCopyMode = False
wsZ.Columns(2).RemoveDuplicates Columns:=1, Header:=xlNo
Workbooks(Datei).Close
Set wsQ = Nothing: Set wsZ = Nothing
End Sub
Gruß Werner
Anzeige

305 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige