AW: Zwei Spalten vergleichen
15.06.2006 13:24:01
Erich G.
Hallo Uwe und Sylvio,
die von Sylvio gepostete Lösung funzt nicht, wenn Spalte B mehr Zeilen hat als Spalte A.
Ich hab sie etwas ausgebaut, drei Varianten sind daraus geworden.
Die erste kopiert das gesamte Quellblatt und arbeitet auf der Kopie,
die zweite legt ein neues Blatt an, das nur die beiden Spalten enthält,
die dritte ist wie die zweite, gibt aber in der dritten Spalte auch die gemeinsamen Werte aus:
Option Explicit
Sub tst()
LoescheGleicheAusZweiSpaltenB Sheets("tst"), "A", "B"
VergleichZweiSpalten ActiveSheet, 1, 2
LoescheGleicheAusZweiSpaltenS Sheets(1), 1, 2
End Sub
Sub LoescheGleicheAusZweiSpaltenB(wsQ As Worksheet, varSp1 As Variant, varSp2 As Variant)
Dim zzA As Long, zzB As Long, aa As Long, bb As Long
wsQ.Copy after:=wsQ ' Quellblatt komplett kopieren
zzA = Cells(Rows.Count, varSp1).End(xlUp).Row
zzB = Cells(Rows.Count, varSp2).End(xlUp).Row
aa = 1
While aa <= zzA
bb = 1
Do While bb <= zzB
If Cells(aa, varSp1) = Cells(bb, varSp2) Then
Cells(aa, varSp1).Delete xlShiftUp: zzA = zzA - 1: aa = aa - 1
Cells(bb, varSp2).Delete xlShiftUp: zzB = zzB - 1
Exit Do
Else
bb = bb + 1
End If
Loop
aa = aa + 1
Wend
End Sub
Sub LoescheGleicheAusZweiSpaltenS(wsQ As Worksheet, varSp1 As Variant, varSp2 As Variant)
Dim zzA As Long, zzB As Long, aa As Long, bb As Long
Worksheets.Add after:=wsQ
wsQ.Columns(varSp1).Copy Cells(1, 1) ' Spalten aus Quellblatt kopieren
wsQ.Columns(varSp2).Copy Cells(1, 2)
zzA = Cells(Rows.Count, 1).End(xlUp).Row
zzB = Cells(Rows.Count, 2).End(xlUp).Row
aa = 1
While aa <= zzA
bb = 1
Do While bb <= zzB
If Cells(aa, 1) = Cells(bb, 2) Then
Cells(aa, 1).Delete xlShiftUp: zzA = zzA - 1: aa = aa - 1
Cells(bb, 2).Delete xlShiftUp: zzB = zzB - 1
Exit Do
Else
bb = bb + 1
End If
Loop
aa = aa + 1
Wend
End Sub
Sub VergleichZweiSpalten(wsQ As Worksheet, varSp1 As Variant, varSp2 As Variant)
Dim zzA As Long, zzB As Long, aa As Long, bb As Long, cc As Long
Worksheets.Add after:=wsQ
wsQ.Columns(varSp1).Copy Cells(1, 1) ' Spalten aus Quellblatt kopieren
wsQ.Columns(varSp2).Copy Cells(1, 2)
zzA = Cells(Rows.Count, 1).End(xlUp).Row
zzB = Cells(Rows.Count, 2).End(xlUp).Row
aa = 1
While aa <= zzA
bb = 1
Do While bb <= zzB
If Cells(aa, 1) = Cells(bb, 2) Then
cc = cc + 1: Cells(cc, 3) = Cells(aa, 1)
Cells(aa, 1).Delete xlShiftUp: zzA = zzA - 1: aa = aa - 1
Cells(bb, 2).Delete xlShiftUp: zzB = zzB - 1
Exit Do
Else
bb = bb + 1
End If
Loop
aa = aa + 1
Wend
Rows(1).Insert ' Spaltenüberschriften
Cells(1, 1) = "nur in " & varSp1
Cells(1, 2) = "nur in " & varSp2
Cells(1, 3) = "gemeinsam"
[A1].Select
End Sub
Rückmeldung wäre nett!
Noch einen schönen Feiertag wünscht Erich aus Kamp-Lintfort