Supportnet / Forum / Tabellenkalkulation
2 Tabellenblätter vergleichen
Frage
Hallo,
nachdem ich nun schon Ewigkeiten hier gesucht, aber nichts passendes gefunden habe, stelle ich mal mein Problem dar:
Ich habe eine Excel-Datei (Excel 2003) mit 2 Tabellenblättern.
In diesen Tabellenblättern sind die Spalten A-Y und ca. 2000 Zeilen vorhanden.
In der Spalte A steht die Kontonummer, nur ist nicht jede Kontonummer aus Tab1 auch in Tab2 vorhanden und umgekehrt. Wenn eine Nummer in beiden Tabellen vorhanden ist, müssen aber auch die Inhalte der anderen Spalten dazu identisch sein. Ist dies nicht der Fall, soll die betroffene Zelle farblich markiert werden.
Beispiel:
Tab1:
A B C D E
1 FO 5 Text1 Text2
4 GB 7 Text1 Tex2a
7 FO 3 Text3 Text2b
Tab2:
A B C D E
2 TR 3 Text Text4
4 GB 7 Text1 Text2a
5 AC 3 Text2 Text5
7 FO 4 Text3 Text2b
Markiert werden soll nun in
Tab1: die Zellen A1 bis E1 und die Zelle C3
Tab2: die Zellen A1 bis E1, A3 bis E3 und C4
Wie kann ich das machen, ich hab allerdings Null Ahnung von VBA :-(.
Viele Grüße
Sigi
Antwort 1 von Kay789
Hab das gleiche Problem wäre dankbar fals Du eine Lösung woanders her haben solltest mir den Link dazu mitzuteilen
Gruß
Kay789
Gruß
Kay789
Antwort 2 von nighty
hi all :-)
wie gewünscht :-))
gruss nighty
Dim zaehler0 As Long
Dim zaehler1 As Long
Dim zaehler2 As Integer
Dim suche As Range
ReDim ExceL(Sheets(1).Range("A" & Rows.Count).End(xlUp).Row)
For zaehler0 = 2 To Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
ExceL(zaehler0) = Sheets(1).Cells(zaehler0, 1)
Next zaehler0
For zaehler0 = 2 To Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
Set suche = Sheets(2).Range("A2:A" & Sheets(2).Range("A" & Rows.Count).End(xlUp).Row).Find(ExceL(zaehler0), LookIn:=xlValues)
If Not suche Is Nothing Then
If Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Column > Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Column Then
zaehler2 = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Column
Else
zaehler2 = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Column
End If
For zaehler1 = 1 To zaehler2
If Sheets(1).Cells(zaehler0, zaehler1) <> Sheets(2).Cells(suche.Row, zaehler1) Then
Sheets(1).Cells(zaehler0, zaehler1).Interior.ColorIndex = 3
Sheets(2).Cells(suche.Row, zaehler1).Interior.ColorIndex = 3
End If
Next zaehler1
End If
Next zaehler0
End Sub
wie gewünscht :-))
gruss nighty
Dim zaehler0 As Long
Dim zaehler1 As Long
Dim zaehler2 As Integer
Dim suche As Range
ReDim ExceL(Sheets(1).Range("A" & Rows.Count).End(xlUp).Row)
For zaehler0 = 2 To Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
ExceL(zaehler0) = Sheets(1).Cells(zaehler0, 1)
Next zaehler0
For zaehler0 = 2 To Sheets(1).Range("A" & Rows.Count).End(xlUp).Row
Set suche = Sheets(2).Range("A2:A" & Sheets(2).Range("A" & Rows.Count).End(xlUp).Row).Find(ExceL(zaehler0), LookIn:=xlValues)
If Not suche Is Nothing Then
If Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Column > Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Column Then
zaehler2 = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Column
Else
zaehler2 = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Column
End If
For zaehler1 = 1 To zaehler2
If Sheets(1).Cells(zaehler0, zaehler1) <> Sheets(2).Cells(suche.Row, zaehler1) Then
Sheets(1).Cells(zaehler0, zaehler1).Interior.ColorIndex = 3
Sheets(2).Cells(suche.Row, zaehler1).Interior.ColorIndex = 3
End If
Next zaehler1
End If
Next zaehler0
End Sub
Antwort 3 von nighty
hi all :)
davon ausgehend
1)zeile1 ueberschrift ist
2)die nummer nur einmal in tab2 existiert
gruss nighty
davon ausgehend
1)zeile1 ueberschrift ist
2)die nummer nur einmal in tab2 existiert
gruss nighty
Antwort 4 von nighty
hi all :-)
erste zeile war glatt abhanden gekommen :-))
gruss nighty
Sub Vergleich()
erste zeile war glatt abhanden gekommen :-))
gruss nighty
Sub Vergleich()
Antwort 5 von sigisuper
Hallo nighty,
vielen Dank für das Makro, habe es ausprobiert, allerdings kommt nicht das Ergebnis, das ich erwartet habe :-(.
In der Tabelle 1 habe ich z.B. eine Kontonummer, die in Tabelle 2 gar nicht vorkommt. Nun habe ich erwartet, dass alle Zellen dieser Zeile markiert werden, das ist aber nicht so, es sind nur einige Zellen rot geworden.
Bei anderen Zeilen hat es dafür allerdings super funktioniert!
Kannst du mir da nochmals helfen? Danke im Voraus und schönes Wochenende
Sigrid
vielen Dank für das Makro, habe es ausprobiert, allerdings kommt nicht das Ergebnis, das ich erwartet habe :-(.
In der Tabelle 1 habe ich z.B. eine Kontonummer, die in Tabelle 2 gar nicht vorkommt. Nun habe ich erwartet, dass alle Zellen dieser Zeile markiert werden, das ist aber nicht so, es sind nur einige Zellen rot geworden.
Bei anderen Zeilen hat es dafür allerdings super funktioniert!
Kannst du mir da nochmals helfen? Danke im Voraus und schönes Wochenende
Sigrid
Antwort 6 von nighty
hi sigrid :-)
der wunsch war eindeutig :-))
gruss nighty
Wenn eine Nummer in beiden Tabellen vorhanden ist, müssen aber auch die Inhalte der anderen Spalten dazu identisch sein. Ist dies nicht der Fall, soll die betroffene Zelle farblich markiert werden.
p.s.
bei bedarf schick mir eine mustertabelle mit konkreten wünschen
oberley@t-online.de mit aussagefähigen betreff bitte :-))
der wunsch war eindeutig :-))
gruss nighty
Wenn eine Nummer in beiden Tabellen vorhanden ist, müssen aber auch die Inhalte der anderen Spalten dazu identisch sein. Ist dies nicht der Fall, soll die betroffene Zelle farblich markiert werden.
p.s.
bei bedarf schick mir eine mustertabelle mit konkreten wünschen
oberley@t-online.de mit aussagefähigen betreff bitte :-))
Antwort 7 von nighty
hi all :-)
was mir noch so einfaellt ,das array liesse sich natuerlich auch in einen rutsch einlesen,bin vergesslich und arbeite mit excel nicht :-))
gruss nighty
was mir noch so einfaellt ,das array liesse sich natuerlich auch in einen rutsch einlesen,bin vergesslich und arbeite mit excel nicht :-))
gruss nighty
Antwort 8 von nighty
hi all :-)
wem es interessiert das war die loesung :-)
erste zeile ueberschriften
auf tabelle 1 + 2 bezogen abgleichung farblich gekennzeichnet,rot fehlende zeilen,gelb unterschiedliche zellen bei vorhandenen beiderseitigen zeilen
als such und vergleichswert habe ich hier zwei zweidimensionales felder angelegt mit den daten der jeweiligen tabellen
gruss nighty
Option Explicit
Sub vergleich()
Dim w1x, w2x, w3x, zaehler1 As Integer
Dim w1y, w2y, w3y, zaehler0 As Long
Dim suche1 As Range
w1x = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Column
w1y = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
w2x = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Column
w2y = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row
If w1x > w2x Then
w3x = w1x
Else
w3x = w2x
End If
If w1y > w2y Then
w3y = w1y
Else
w3y = w2y
End If
ReDim excel1(w3y, w3x)
ReDim excel2(w3y, w3x)
Sheets(1).Select
excel1() = Range(Cells(1, 1), Cells(w3y, w3x))
Sheets(2).Select
excel2() = Range(Cells(1, 1), Cells(w3y, w3x))
Sheets(1).Select
For zaehler0 = 2 To w3y
Set suche1 = Sheets(2).Range("A1:A" & w3y).Find(excel1(zaehler0, 1), Lookat:=xlWhole)
If Not suche1 Is Nothing Then
For zaehler1 = 2 To w3x
If excel1(zaehler0, zaehler1) <> "" And excel1(zaehler0, zaehler1) <> excel2(suche1.Row, zaehler1) Then
Cells(zaehler0, zaehler1).Interior.ColorIndex = 6
End If
Next zaehler1
Else
Sheets(1).Range(Cells(zaehler0, 1), Cells(zaehler0, w3x)).Interior.ColorIndex = 3
End If
Next zaehler0
Sheets(2).Select
For zaehler0 = 2 To w3y
Set suche1 = Sheets(1).Range("A1:A" & w3y).Find(excel2(zaehler0, 1), Lookat:=xlWhole)
If Not suche1 Is Nothing Then
For zaehler1 = 2 To w3x
If excel2(zaehler0, zaehler1) <> "" And excel2(zaehler0, zaehler1) <> excel1(suche1.Row, zaehler1) Then
Cells(zaehler0, zaehler1).Interior.ColorIndex = 6
End If
Next zaehler1
Else
Sheets(2).Range(Cells(zaehler0, 1), Cells(zaehler0, w3x)).Interior.ColorIndex = 3
End If
Next zaehler0
Sheets(1).Select
End Sub
wem es interessiert das war die loesung :-)
erste zeile ueberschriften
auf tabelle 1 + 2 bezogen abgleichung farblich gekennzeichnet,rot fehlende zeilen,gelb unterschiedliche zellen bei vorhandenen beiderseitigen zeilen
als such und vergleichswert habe ich hier zwei zweidimensionales felder angelegt mit den daten der jeweiligen tabellen
gruss nighty
Option Explicit
Sub vergleich()
Dim w1x, w2x, w3x, zaehler1 As Integer
Dim w1y, w2y, w3y, zaehler0 As Long
Dim suche1 As Range
w1x = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Column
w1y = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
w2x = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Column
w2y = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row
If w1x > w2x Then
w3x = w1x
Else
w3x = w2x
End If
If w1y > w2y Then
w3y = w1y
Else
w3y = w2y
End If
ReDim excel1(w3y, w3x)
ReDim excel2(w3y, w3x)
Sheets(1).Select
excel1() = Range(Cells(1, 1), Cells(w3y, w3x))
Sheets(2).Select
excel2() = Range(Cells(1, 1), Cells(w3y, w3x))
Sheets(1).Select
For zaehler0 = 2 To w3y
Set suche1 = Sheets(2).Range("A1:A" & w3y).Find(excel1(zaehler0, 1), Lookat:=xlWhole)
If Not suche1 Is Nothing Then
For zaehler1 = 2 To w3x
If excel1(zaehler0, zaehler1) <> "" And excel1(zaehler0, zaehler1) <> excel2(suche1.Row, zaehler1) Then
Cells(zaehler0, zaehler1).Interior.ColorIndex = 6
End If
Next zaehler1
Else
Sheets(1).Range(Cells(zaehler0, 1), Cells(zaehler0, w3x)).Interior.ColorIndex = 3
End If
Next zaehler0
Sheets(2).Select
For zaehler0 = 2 To w3y
Set suche1 = Sheets(1).Range("A1:A" & w3y).Find(excel2(zaehler0, 1), Lookat:=xlWhole)
If Not suche1 Is Nothing Then
For zaehler1 = 2 To w3x
If excel2(zaehler0, zaehler1) <> "" And excel2(zaehler0, zaehler1) <> excel1(suche1.Row, zaehler1) Then
Cells(zaehler0, zaehler1).Interior.ColorIndex = 6
End If
Next zaehler1
Else
Sheets(2).Range(Cells(zaehler0, 1), Cells(zaehler0, w3x)).Interior.ColorIndex = 3
End If
Next zaehler0
Sheets(1).Select
End Sub
Antwort 9 von sigisuper
Hi nighty,
danke vielmals, es funktioniert!
Gruß
Sigrid
danke vielmals, es funktioniert!
Gruß
Sigrid
Antwort 10 von nighty
hi all :-)
noch ein wenig optimiert :-))
gruss nighty
Option Explicit
Sub vergleich()
Dim w1x, w2x, w3x, zaehler1 As Integer
Dim w1y, w2y, w3y, zaehler0 As Long
Dim suche1, suche2 As Range
w1x = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Column
w1y = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
w2x = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Column
w2y = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row
If w1x > w2x Then
w3x = w1x
Else
w3x = w2x
End If
If w1y > w2y Then
w3y = w1y
Else
w3y = w2y
End If
ReDim excel1(w3y, w3x) As Variant
ReDim excel2(w3y, w3x) As Variant
Sheets(2).Select
excel2() = Range(Cells(1, 1), Cells(w3y, w3x))
Sheets(1).Select
excel1() = Range(Cells(1, 1), Cells(w3y, w3x))
For zaehler0 = 2 To w3y
Set suche1 = Sheets(2).Range("A1:A" & w3y).Find(excel1(zaehler0, 1), Lookat:=xlWhole)
Set suche2 = Sheets(1).Range("A1:A" & w3y).Find(excel2(zaehler0, 1), Lookat:=xlWhole)
If Not suche1 Is Nothing Then
For zaehler1 = 2 To w3x
If excel1(zaehler0, zaehler1) <> "" And excel1(zaehler0, zaehler1) <> excel2(suche1.Row, zaehler1) Then
Sheets(1).Cells(zaehler0, zaehler1).Interior.ColorIndex = 6
End If
Next zaehler1
Else
Sheets(1).Range(Sheets(1).Cells(zaehler0, 1), Sheets(1).Cells(zaehler0, w3x)).Interior.ColorIndex = 3
End If
If Not suche2 Is Nothing Then
For zaehler1 = 2 To w3x
If excel2(zaehler0, zaehler1) <> "" And excel2(zaehler0, zaehler1) <> excel1(suche2.Row, zaehler1) Then
Sheets(2).Cells(zaehler0, zaehler1).Interior.ColorIndex = 6
End If
Next zaehler1
Else
Sheets(2).Range(Sheets(2).Cells(zaehler0, 1), Sheets(2).Cells(zaehler0, w3x)).Interior.ColorIndex = 3
End If
Next zaehler0
End Sub
noch ein wenig optimiert :-))
gruss nighty
Option Explicit
Sub vergleich()
Dim w1x, w2x, w3x, zaehler1 As Integer
Dim w1y, w2y, w3y, zaehler0 As Long
Dim suche1, suche2 As Range
w1x = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Column
w1y = Sheets(1).UsedRange.SpecialCells(xlCellTypeLastCell).Row
w2x = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Column
w2y = Sheets(2).UsedRange.SpecialCells(xlCellTypeLastCell).Row
If w1x > w2x Then
w3x = w1x
Else
w3x = w2x
End If
If w1y > w2y Then
w3y = w1y
Else
w3y = w2y
End If
ReDim excel1(w3y, w3x) As Variant
ReDim excel2(w3y, w3x) As Variant
Sheets(2).Select
excel2() = Range(Cells(1, 1), Cells(w3y, w3x))
Sheets(1).Select
excel1() = Range(Cells(1, 1), Cells(w3y, w3x))
For zaehler0 = 2 To w3y
Set suche1 = Sheets(2).Range("A1:A" & w3y).Find(excel1(zaehler0, 1), Lookat:=xlWhole)
Set suche2 = Sheets(1).Range("A1:A" & w3y).Find(excel2(zaehler0, 1), Lookat:=xlWhole)
If Not suche1 Is Nothing Then
For zaehler1 = 2 To w3x
If excel1(zaehler0, zaehler1) <> "" And excel1(zaehler0, zaehler1) <> excel2(suche1.Row, zaehler1) Then
Sheets(1).Cells(zaehler0, zaehler1).Interior.ColorIndex = 6
End If
Next zaehler1
Else
Sheets(1).Range(Sheets(1).Cells(zaehler0, 1), Sheets(1).Cells(zaehler0, w3x)).Interior.ColorIndex = 3
End If
If Not suche2 Is Nothing Then
For zaehler1 = 2 To w3x
If excel2(zaehler0, zaehler1) <> "" And excel2(zaehler0, zaehler1) <> excel1(suche2.Row, zaehler1) Then
Sheets(2).Cells(zaehler0, zaehler1).Interior.ColorIndex = 6
End If
Next zaehler1
Else
Sheets(2).Range(Sheets(2).Cells(zaehler0, 1), Sheets(2).Cells(zaehler0, w3x)).Interior.ColorIndex = 3
End If
Next zaehler0
End Sub