Supportnet Computer
Planet of Tech

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

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

Antwort 3 von nighty

hi all :)

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()

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

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 :-))

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

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

Antwort 9 von sigisuper

Hi nighty,
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

Ich möchte kostenlos eine Frage an die Mitglieder stellen:


Ähnliche Themen:


Suche in allen vorhandenen Beiträgen: