AW: Große Tabellen vergleichen
07.10.2008 18:36:52
fcs
Hallo Gerwas,
prinzipiell kann man einen derartigen Vergleich mit nachfolgendem Makro durchführen.
Allerdings gibt es dann immer noch das Problem der Ergebnisnissausgabe bzw. was willst du mit den Zeilennummern anfangen.
In meiner Lösung werden die Fundstelen in ein Datenarray geschrieben und in einer Textbox ausgegeben.
Gruß
Franz
Sub Vergleich()
Dim wksA As Worksheet, wksB As Worksheet, rngBereich As Range
Dim SpA As Long, SpB As Long
Dim lngZeileA As Long, lngFund As Long, strFund As String, strBox As String
Dim lngCountB, arrZeilenB() As Long, rngSuchen As Range
Dim varSuchen
Dim strAdr1 As String
Set wksA = Worksheets("TabelleA")
Set wksB = Worksheets("TabelleB")
SpA = 1 'Spalte mit Texten in Tabelle A
SpB = 1 'Spalte mit Texten in Tabelle B
With wksB
Set rngBereich = .Columns(SpB) 'zu durchsuchender Bereich in Blatt B
End With
For lngZeileA = 1 To IIf(IsEmpty(wksA.Cells(wksA.Rows.Count, SpA)), _
wksA.Cells(wksA.Rows.Count, SpA).End(xlUp).Row, wksA.Rows.Count)
varSuchen = wksA.Cells(lngZeileA, SpA)
strFund = ""
'Prüfen ob Suchtext erstmals gesucht werden soll, bei Wiederholung keine Berechnung
If Application.WorksheetFunction.CountIf(wksA.Range(wksA.Cells(1, SpA), _
wksA.Cells(lngZeileA, SpA)), varSuchen) = 1 Then
Set rngSuchen = rngBereich.Find(what:=varSuchen, LookIn:=xlValues, lookat:=xlWhole)
If rngSuchen Is Nothing Then
lngCountB = 0
Else
strAdr1 = rngSuchen.Address
lngCountB = 0
Do
lngCountB = lngCountB + 1
ReDim Preserve arrZeilenB(1 To lngCountB)
arrZeilenB(lngCountB) = rngSuchen.Row
Set rngSuchen = rngBereich.FindNext(rngSuchen)
Loop Until rngSuchen.Address = strAdr1
End If
'Ausgabe Ergebnis
If lngCountB = 0 Then
If MsgBox(varSuchen & " in Tabelle " & wksB.Name & " nicht gefunden!", _
vbOKCancel) = vbCancel Then Exit Sub
Else
strBox = varSuchen & " in Tabelle " & wksB.Name & " gefunden: " & lngCountB & " mal"
strBox = strBox & vbLf & "Fundstellen 1 bis "
For lngFund = 1 To lngCountB
strFund = strFund & vbLf & arrZeilenB(lngFund)
If lngFund Mod 20 = 0 Then
strBox = strBox & lngFund & strFund
If MsgBox(strBox, vbOKCancel) = vbCancel Then Exit Sub
strBox = varSuchen & " in Tabelle " & wksB.Name & " gefunden: " & lngCountB & " mal" _
strBox = strBox & vbLf & "Fundstellen " & lngFund + 1 & " bis "
strFund = ""
End If
Next
If strFund "" Then
strBox = strBox & lngCountB & strFund
If MsgBox(strBox, vbOKCancel) = vbCancel Then Exit Sub
End If
ReDim arrZeilenB(1 To 1)
End If
End If
Next
End Sub