AW: Spaltenvergleich mit Bedingung
08.07.2014 13:51:29
Hajo_Zi
sollte man nicht den gesamten Code kopieren, dann wird es vom Forum auch richtig eingerückt oder man benutzt den Schalter Code. Damit ist der Code übersichtlicher.
Ungetestet.
Option Explicit
Sub Tabellen_Vergleichtest()
'* H. Ziplies *
'* 08.07.14 *
'* erstellt von HajoZiplies@web.de *
'* http://Hajo-Excel.de/
Dim LoI As Long ' 1. Schleifenvariable
Dim LoJ As Long ' 2. Schleifenvariable
Dim LoLetzte1 As Long ' Variable letzte Zeile in Spalte A
Dim LoLetzte2 As Long ' Variable letzte Zeile in Spalte B
Dim Loletzte3 As Long ' Variable letzte Zeile in Tabelle3
Application.ScreenUpdating = False ' Bildschirmaktualisierung aus
With Worksheets("Tabelle1") ' letzte Zeile in Spalte A Tabelle1
LoLetzte1 = IIf(IsEmpty(.Cells(Rows.Count, 3)), _
.Cells(Rows.Count, 3).End(xlUp).Row, .Rows.Count)
End With
With Worksheets("Tabelle2") ' letzte Zeile in Spalte B Tabelle2
LoLetzte2 = IIf(IsEmpty(.Cells(Rows.Count, 3)), _
.Cells(Rows.Count, 3).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, 3) <> "" Then
If Worksheets("Tabelle1").Cells(LoI, 3) = _
Worksheets("Tabelle2").Cells(LoJ, 3) And Worksheets("Tabelle1").Cells(LoI, _
12) = "YES" Then
' Zellen sind gleich, Zeile Kopieren
Worksheets("Tabelle2").Rows(LoJ).Copy
With Worksheets("Tabelle3")
' 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
' Zellinhalt entfernen
Worksheets("Tabelle2").Rows(LoJ).ClearContents
' Zeile Löschen
'Worksheets("Tabelle2").Rows(LoJ).Delete
End With
' innere Schleife verlassen da Datensatz gefunden
Exit For
End If
End If
Next LoJ
Next LoI
Application.CutCopyMode = False ' Zwischenspeicher löschen
Application.ScreenUpdating = True ' Bildschirmaktualisierung ein
End Sub