AW: zwei Tabellen sortieren und vergleichen
08.05.2015 01:28:59
fcs
Hallo Shahed,
ich hab das Makro jetzt so erweitert, dass in einer Input-Box weitere Spalten angegeben werden können, nach denen sortiert werden soll.
Gruß
Franz
Sub Tabellenvergleich()
Dim wkb_1 As Workbook, wkb_2 As Workbook
Dim wks_1 As Worksheet, wks_2 As Worksheet
Dim wks_Ergebnis As Worksheet
Dim arrData1, arrData2, arrDataE()
Dim Zeile_L As Long, Spalte_L As Long
Dim Zeile As Long, Spalte As Long
Dim ZeileE As Long
Dim strSort As String, varSplit, intSort As Integer
Set wkb_1 = ActiveWorkbook 'Arbeitsmappe mit 1. Tabelle ggf. anpassen
Set wkb_2 = ActiveWorkbook 'Arbeitsmappe mit 2. Tabelle ggf. anpassen
Set wks_1 = wkb_1.Worksheets(1) '1. Tabelle - Indexnummer ggf. anpassen
Set wks_2 = wkb_2.Worksheets(2) '2. Tabelle - Indexnummer ggf. anpassen
strSort = InputBox("zusätzlich zu sortierende Spalte(n) außer ""B-C-M""" & vbLf _
& "(Spalten jeweils duch Semicolon trennen, z.B.: K;L)" & vbLf _
& "(Bei Abbrechen wird nur nach ""B-C-M"" sortiert)", "Sortierreihenfolge", "")
Application.ScreenUpdating = False
With wks_1
Application.StatusBar = "Tabelle """ & .Name & """ wird sortiert und eingelesen"
'Zellfarbe zurücksetzen
.UsedRange.Interior.ColorIndex = xlColorIndexNone
'Daten sortieren
Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
Spalte_L = .Cells(1, .Columns.Count).End(xlToLeft).Column
With .Range(.Cells(1, 1), .Cells(Zeile_L, Spalte_L))
If strSort "" Then
varSplit = Split(strSort, ";")
For intSort = UBound(varSplit) To LBound(varSplit) Step -1
.Sort key1:=.Range(Trim(varSplit(intSort)) & "1"), order1:=xlAscending, Header:=xlYes
Next
End If
.Sort key1:=.Range("B1"), order1:=xlAscending, _
key2:=.Range("C1"), order2:=xlAscending, _
key3:=.Range("M1"), order3:=xlAscending, Header:=xlYes
End With
'Daten in Array einlesen
arrData1 = .Range(.Cells(1, 1), .Cells(Zeile_L, Spalte_L))
End With
With wks_2
Application.StatusBar = "Tabelle """ & .Name & """ wird sortiert und eingelesen"
'Zellfarbe zurücksetzen
.UsedRange.Interior.ColorIndex = xlColorIndexNone
'Daten sortieren
Zeile_L = .UsedRange.Row + .UsedRange.Rows.Count - 1
Spalte_L = .Cells(1, .Columns.Count).End(xlToLeft).Column
With .Range(.Cells(1, 1), .Cells(Zeile_L, Spalte_L))
If strSort "" Then
varSplit = Split(strSort, ";")
For intSort = UBound(varSplit) To LBound(varSplit) Step -1
.Sort key1:=.Range(Trim(varSplit(intSort)) & "1"), order1:=xlAscending, Header:=xlYes
Next
End If
.Sort key1:=.Range("B1"), order1:=xlAscending, _
key2:=.Range("C1"), order2:=xlAscending, _
key3:=.Range("M1"), order3:=xlAscending, Header:=xlYes
End With
'Daten in Array einlesen
arrData2 = .Range(.Cells(1, 1), .Cells(Zeile_L, Spalte_L))
End With
Application.StatusBar = "Daten vergleichen und Auswertungstabelle erstellen"
'Spaltentitel ins Ergebnisarray schreiben
'Ergebnisarray mit dimensionieren
ZeileE = 1
ReDim arrDataE(1 To 4, 1 To ZeileE)
arrDataE(1, ZeileE) = "Zeile"
arrDataE(2, ZeileE) = "Spalte"
arrDataE(3, ZeileE) = wks_1.Name
arrDataE(4, ZeileE) = wks_2.Name
'Alt-Daten abarbeiten
For Zeile = 1 To UBound(arrData1, 1)
For Spalte = LBound(arrData1, 2) To UBound(arrData1, 2)
If arrData1(Zeile, Spalte) arrData2(Zeile, Spalte) Then
ZeileE = ZeileE + 1
ReDim Preserve arrDataE(1 To 4, 1 To ZeileE)
arrDataE(1, ZeileE) = Zeile
arrDataE(2, ZeileE) = Spalte
arrDataE(3, ZeileE) = arrData1(Zeile, Spalte)
arrDataE(4, ZeileE) = arrData2(Zeile, Spalte)
wks_1.Cells(Zeile, Spalte).Interior.ColorIndex = 6
wks_2.Cells(Zeile, Spalte).Interior.ColorIndex = 6
End If
Next
Next Zeile
If ZeileE > 1 Then
Application.Workbooks.Add template:=xlWBATWorksheet
Set wks_Ergebnis = ActiveWorkbook.Worksheets(1)
With wks_Ergebnis
.Cells(1, 1).Resize(ZeileE, 4) = Application.WorksheetFunction.Transpose(arrDataE)
End With
Else
MsgBox "alle Datensätze in den Tabellen sind identisch"
End If
Erase arrData1, arrData2, arrDataE
Application.StatusBar = False
Application.ScreenUpdating = True
'MsgBox "Fertig"
End Sub