AW: Werte von 2 Tabellen vergleichen
19.11.2018 17:39:17
2
Ich hätte dir da mal was gebaut, wobei ich von folgendem ausgehe:
Tabellenblatt1 ist deine Wertemappe, Tabellenblatt2 deine Auswertung, ab Tabellenblatt 3 dann die ganzen Vergleiche. Weiterhin habe ich angenommen, dass die zu vergleichenden Werte in den jeweiligen Tabellenblättern auch in Spalte A stehen (ansonsten anpassen). In der Auswertung befindet sich die Beschriftungen in Spalte A so, wie die Tabellenblätter heißen (also in Zeile 1, Spalte A steht: Vergleich1, in Zeile 2 steht: Vergleich2 usw). Das alles müsstest du halt anpassen, wenn es so nicht stimmt.
Hier mal mein Code:
Sub Auswerten()
Dim wkb As Workbook
Dim ws_Werte As Worksheet
Dim ws_Auswert As Worksheet
Dim lz_Werte As Long
Dim lz_Vergl As Long
Dim lz_Auswert As Long
Dim a As Long
Dim i As Long
Dim x As Long
Dim y As Long
Dim z As Long
Dim Anzahl As Long
Dim Arr
Dim Arr_Vergl
Dim Arr_Doppelt
Set wkb = ThisWorkbook
Set ws_Werte = wkb.Worksheets("Wertemappe")
Set ws_Auswert = wkb.Worksheets("Auswertung")
lz_Werte = ws_Werte.Cells(Rows.Count, 1).End(xlUp).Row
lz_Auswert = ws_Auswert.Cells(Rows.Count, 1).End(xlUp).Row
ReDim Arr_Doppelt(lz_Werte - 1, 0)
Anzahl = wkb.Worksheets.Count
Arr = ws_Werte.Range("A1:A" & lz_Werte)
ws_Auswert.Range("B1:B" & lz_Auswert).Delete 'Die Werte in Spalte B der Auswertung werden _
gel?scht
For i = 3 To Anzahl 'Wenn im zweiten Tabellenblatt die Auswertung steht
With wkb.Worksheets(i)
lz_Vergl = .Cells(Rows.Count, 1).End(xlUp).Row
Arr_Vergl = .Range("A1:A" & lz_Vergl)
End With
For x = LBound(Arr) To UBound(Arr)
For y = LBound(Arr_Vergl) To UBound(Arr_Vergl)
If Arr(x, 1) = Arr_Vergl(y, 1) Then
Debug.Print Arr(x, 1)
lz_Auswert = ws_Auswert.Cells(Rows.Count, 1).End(xlUp).Row
For z = 1 To lz_Auswert
If ws_Auswert.Range("A" & z) = wkb.Worksheets(i).Name Then
ws_Auswert.Range("B" & z) = ws_Auswert.Range("B" & z) + 1
End If
Next z
Arr_Doppelt(a, 0) = Arr(x, 1)
a = a + 1
End If
Next y
Next x
Next i
For i = LBound(Arr_Doppelt) To UBound(Arr_Doppelt)
For a = lz_Werte To 1 Step -1
If Arr_Doppelt(i, 0) = ws_Werte.Range("A" & a).Value Then
ws_Werte.Range("A" & a).Delete
End If
Next a
Next i
End Sub
Gruß Oisse