Moin!
HIer mal eine Variante mit ganz viel grün. :-) Das grüne kannst du später auch löschen, da es beim Lesen des eigentlichen COdes nur stört.
Wenn Fragen dazu sind, einfach meldem.
Schönes Wochenende noch.
Option Explicit
Sub vergleichen()
'Variablen und Objecte die benötigt werden.
Dim j As Long 'Zähler
Dim eins As Object ' für das 1.Arbeitsblatt
Dim zwei As Object ' für das 2.Arbeitsblatt
Dim anzahl As Long ' Anzahl der Wert
Dim zeile As Long ' Zeile mit dem Wert in Blatt 2
Dim anders As Long ' Anzahl der unterschiedlichen Preise des Wertes
Dim ende As Long ' für die letzte Zeile in Blatt 2
'erstmal Aktualsisierungen des Bildschirms ausschalten
Application.ScreenUpdating = False
'um die richtigen Stellen anzusprechen und später nicht immer Worksheets(1) etc. zu schreiben, die Namen anderen Objekten zuweisen
'macht das kürzer und man erkennt noch wo man ist
Set eins = Worksheets(1) 'Objekt auf das Blatt1
Set zwei = Worksheets(2) 'Objekt auf das Blatt2
'da im Blatt 2 Unterschiede hervorgehoben werden sollen, erstmal die alten Farben im ganzen Blatt 2 löschen
zwei.UsedRange.Interior.ColorIndex = xlNone
'jetzt beginnt die Prüfung
If eins.Cells(2, 1) <> "" Then
' in Zelle A2 steht nix, dann nix machen (würde in die else Schleife kommen, da dort nix gemacht wird habe ich sie weggelassen).
'Es geht also weiter, wenn was in A2 steht.
'prüfen, ob der Wert in Blatt 2 schonmal virkokmmt. deshalb einfach die Anzahl zählen lassen. Sollte beim Treffer größer 1 sein. Sonst 0.
anzahl = Application.WorksheetFunction.CountIf(zwei.Columns(1), eins.Cells(2, 1))
If anzahl = 0 Then ' es wurde kein Wert gefunden, also neu eintragen
'die letzte Zeile in Blatt 2 finden, dort wollen wir ja eintragen
ende = zwei.Cells(Rows.Count, 1).End(xlUp).Row
'falls die liste noch leer ist, mal prüfen, wo ende genau war. bei 1 auf 3 setzen - später wird beim Code 1 dazugezählt so das beim ersten Eintrag A4 kommen würde
If ende = 1 Then ende = 3
'jetzt die Zeile 2 von Blatt eins, ans Ende de Einträge von Blatt 2 kopieren
' die Zeile dafür ist ende +1 = letzte beschriebene Zeile + 1 ,
eins.Rows(2).Copy zwei.Rows(ende + 1)
'die erste Zelle des Eintrags markieren, damit man ihn gleich sieht
zwei.Cells(ende + 1, 1).Interior.ColorIndex = 6
'Meldung für den Anwender
MsgBox "Die Daten waren noch nicht vorhanden. Sie wurden am Ende eingefügt!"
Else
'Zähler fpr die Änderungen auf 0
anders = 0
'die Zeile mit dem Eintrag suchen
zeile = Application.WorksheetFunction.Match(eins.Cells(2, 1), zwei.Columns(1), 0)
'jetzt die Spaöte C bis I vergleichen.
For j = 3 To 9
If zwei.Cells(zeile, j) <> eins.Cells(2, j) Then ' Werte unterscheiden sich
zwei.Cells(zeile, j).Interior.ColorIndex = 6 ' Wert markieren
anders = anders + 1 ' Zähler hochsetzen
End If
Next j
'die erste Zelle des Eintrags markieren, damit man ihn gleich sieht
zwei.Cells(zeile, 1).Interior.ColorIndex = 6
' noch eine NAchricht
If anders = 0 Then
MsgBox "Die Daten waren mit den selben Werten vorhanden!"
Else
MsgBox "Die Daten waren vorhanden! Es gab allerdings " & anzahl & " unterschiedliche Werte. Diese wurden farbig markiert aber nicht geändert."
End If
End If
End If
'die Objekte wieder ins nirvana schicken.
Set eins = Nothing
Set zwei = Nothing
'und Aktualsisierungen wieder einschalten
Application.ScreenUpdating = True
End Sub
|