Es wird nur der erste Wert gefunden
08.05.2017 14:24:31
Georg
Es funktioniert, aber es wird jeweils nur der erste Treffer kopiert. Weitere Zeilen mit der gleichen PLZ werden nicht kopiert. ich weiß leider nicht warum.
In meiner Musterdatei habe ich zwei PLZ, die übereinstimmen, und ich bekomme immer nur zwei Datensätze kopiert, es müssten aber 8 sein.
Sub Tabellen_Vergleich()
Dim LoI As Long
Dim LoJ As Long
Dim LoLetzte1 As Long
Dim LoLetzte2 As Long
Dim Loletzte3 As Long
Application.ScreenUpdating = False
With Worksheets("Tabelle1")
LoLetzte1 = IIf(IsEmpty(.Cells(Rows.Count, 1)), _
.Cells(Rows.Count, 1).End(xlUp).Row, .Rows.Count)
End With
With Worksheets("Gesamt") ' letzte Zeile in Spalte G "Gesamt"
LoLetzte2 = IIf(IsEmpty(.Cells(Rows.Count, 7)), _
.Cells(Rows.Count, 7).End(xlUp).Row, .Rows.Count)
End With
For LoI = 1 To LoLetzte1 ' 1. Schleife alle Werte Spalte A
For LoJ = 1 To LoLetzte2 ' 2. Schleife alle Werte Spalte B
' Leerzellen nicht kennzeichnen
If Worksheets("Tabelle1").Cells(LoI, 1) "" Then
If Worksheets("Tabelle1").Cells(LoI, 1) = _
Worksheets("Gesamt").Cells(LoJ, 7) Then
Worksheets("Gesamt").Rows(LoJ).Copy
With Worksheets("Tabelle2")
' letzte belegte Zeile in Tabelle3 ermitteln
Loletzte3 = .UsedRange.SpecialCells(xlCellTypeLastCell).Row + 1
' ermittelte Zeilennummer mit max. Anzahl vergleichen
If Loletzte3 > Rows.Count Then
MsgBox "In Tabelle3 ist keine Zeile mehr frei"
' Zwischenspeicher löschen
Application.CutCopyMode = False
Exit Sub
End If
' Werte übertragen
.Rows(Loletzte3).PasteSpecial Paste:=xlValues
' Formate übertragen
.Rows(Loletzte3).PasteSpecial Paste:=xlFormats
End With
' innere Schleife verlassen da Datensatz gefunden
Exit For
End If
End If
Next LoJ
Next LoI
Application.CutCopyMode = False
Application.ScreenUpdating = True
End Sub