Anzeige
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender

Forumthread: Tabellenvergleich- Abweichungen markieren

Tabellenvergleich- Abweichungen markieren
17.06.2009 15:22:23
Bibo
Hallo liebe EXCEL-Freunde bzw. VBA-Spezialisten,
ich habe hier im Forum eine Sub-Anweisung von Peter Feustel gefunden und in der Beispielmappe für meine Belange versucht anzupassen.
Das Auffinden und Markieren der Abweichungen funktioniert auch ganz ausgezeichnet solange, wie die Datenstruktur in den Tabellenblätter Bestand_alt und Bestand_neu identisch ist und nur einzelne Werte voneinander abweichen.
Sobald ein oder mehrere Datensätze im Tabellenblatt Bestand_neu jedoch nicht mehr vorhanden sind und sich somit die Matrix verschiebt, kommt es zu falschen Ergebnissen.
Hier ist noch der Original-Code von Peter Feustel:

Sub vergleichMatrix()
Dim arr1 As Variant
Dim arr2 As Variant
Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim strRange As String
Dim n As Long, m As Long
strRange = "A1:CV10000" 'Bereich der verglichen wird - anpassen
Set wks1 = Sheets("Tabelle1")
'Tabelle1 - anpassen
Set wks2 = Sheets("Tabelle2")
'Tabelle2 - anpassen, in dieser Tabelle wird gekennzeichnet!
arr1 = wks1.Range(strRange)
arr2 = wks2.Range(strRange)
For m = 1 To UBound(arr1, 2)
For n = 1 To UBound(arr1, 1)
If arr1(n, m)  arr2(n, m) Then
wks2.Range(strRange).Cells(n, m).Interior.ColorIndex = 6
End If
Next
Next
End Sub


Lässt sich die Anweisung so anpassen, dass die Markierung der Abweichungen unabhängig von der Reihenfolge der Datensätze in den Tabellenblättern richtig vorgenommen wird?
Ich bitte Euch um Hilfe und danke schon im Voraus.
Hallo liebe EXCEL-Freunde bzw. VBA-Spezialisten,
ich habe hier im Forum eine Sub-Anweisung von Peter Feustel gefunden und in der Beispielmappe für meine Belange versucht anzupassen.
Das Auffinden und Markieren der Abweichungen funktioniert auch ganz ausgezeichnet solange, wie die Datenstruktur in den Tabellenblätter Bestand_alt und Bestand_neu identisch ist und nur einzelne Werte voneinander abweichen.
Sobald ein oder mehrere Datensätze im Tabellenblatt Bestand_neu jedoch nicht mehr vorhanden sind und sich somit die Matrix verschiebt, kommt es zu falschen Ergebnissen.
Hier ist noch der Original-Code von Peter Feustel:


Sub vergleichMatrix()
Dim arr1 As Variant
Dim arr2 As Variant
Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim strRange As String
Dim n As Long, m As Long
strRange = "A1:CV10000" 'Bereich der verglichen wird - anpassen
Set wks1 = Sheets("Tabelle1")
'Tabelle1 - anpassen
Set wks2 = Sheets("Tabelle2")
'Tabelle2 - anpassen, in dieser Tabelle wird gekennzeichnet!
arr1 = wks1.Range(strRange)
arr2 = wks2.Range(strRange)
For m = 1 To UBound(arr1, 2)
For n = 1 To UBound(arr1, 1)
If arr1(n, m)  arr2(n, m) Then
wks2.Range(strRange).Cells(n, m).Interior.ColorIndex = 6
End If
Next
Next
End Sub


Lässt sich die Anweisung so anpassen, dass die Markierung der Abweichungen unabhängig von der Reihenfolge der Datensätze in den Tabellenblättern richtig vorgenommen wird?
Ich bitte Euch um Hilfe und danke schon im Voraus.
Mit freundlichem Gruß
Bibo
https://www.herber.de/bbs/user/62517.xls

Anzeige

2
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Tabellenvergleich- Abweichungen markieren
17.06.2009 17:47:30
fcs
Hallo Bibo,
Durch Vergleich ob KST und Artikel neu oder noch vorhanden sind kann man die Tabellen auch vergleichen.
Änderungen und neue Einträge im Bestand werden gelb gekennzeichent.
Die in Neu nicht mehr vorhanden Einträge werden in Alt rot gekennzeichnet.
Gruß
Franz

Option Explicit
Sub Vergleich_Neu_Alt()
'Unterschiedliche Einträge in den Tabellen markieren
Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim ZeileNeu As Long, Spalte As Long, Zelle As Range
Dim varKst, varArt, strAdresse1 As String, gefunden As Boolean
Set wks1 = Sheets("Bestand_alt")
'Tabelle1 - anpassen
Set wks2 = Sheets("Bestand_neu")
'Tabelle2 - anpassen, in dieser Tabelle wird gekennzeichnet!
'Farbmarkierungen zurücksetzen
With wks1
.UsedRange.Interior.ColorIndex = xlColorIndexNone
End With
With wks2
.UsedRange.Interior.ColorIndex = xlColorIndexNone
End With
For ZeileNeu = 2 To wks2.Cells(wks2.Rows.Count, 1).End(xlUp).Row
varKst = wks2.Cells(ZeileNeu, 1).Value 'Kostenstelle - neu
varArt = wks2.Cells(ZeileNeu, 2).Value 'Artikel - neu
'Kst in alt suchen
Set Zelle = wks1.Columns(1).Find(what:=varKst, LookIn:=xlValues, _
lookat:=xlWhole)
strAdresse1 = Zelle.Address
gefunden = False
If Not Zelle Is Nothing Then
Do
'Prüfen ob und Artikel übereinstimmt
If varArt = wks1.Cells(Zelle.Row, 2) Then
gefunden = True
'Spalten C bis G in den Zeilen vergleichen
For Spalte = 3 To 7
If wks1.Cells(Zelle.Row, Spalte).Value _
 wks2.Cells(ZeileNeu, Spalte).Value Then
'Zelle gelb markieren
wks2.Cells(ZeileNeu, Spalte).Interior.ColorIndex = 6
wks1.Cells(Zelle.Row, Spalte).Interior.ColorIndex = 6
End If
Next
Exit Do
End If
'Nächsten KST-Eintrag suchen
Set Zelle = wks1.Columns(1).FindNext(after:=Zelle)
Loop Until Zelle.Address = strAdresse1
End If
If gefunden = False Then
With wks2
'Spalten A bis G in zeile gelb markieren
.Range(.Cells(ZeileNeu, 1), .Cells(ZeileNeu, 7)).Interior.ColorIndex = 6
End With
End If
Next
Call vergleichMatrixgeloescht
End Sub
Sub vergleichMatrixgeloescht()
'gelöschte Einträge im Bestand alt markieren
Dim wks1 As Worksheet
Dim wks2 As Worksheet
Dim ZeileAlt As Long, Zelle As Range
Dim varKst, varArt, strAdresse1 As String, gefunden As Boolean
Set wks1 = Sheets("Bestand_neu")
'Tabelle1 - anpassen
Set wks2 = Sheets("Bestand_alt")
'Tabelle2 - anpassen, in dieser Tabelle wird gekennzeichnet!
For ZeileAlt = 2 To wks2.Cells(wks2.Rows.Count, 1).End(xlUp).Row
varKst = wks2.Cells(ZeileAlt, 1).Value 'Kostenstelle - alt
varArt = wks2.Cells(ZeileAlt, 2).Value 'Artikel - alt
'Kst in neu suchen
Set Zelle = wks1.Columns(1).Find(what:=varKst, LookIn:=xlValues, _
lookat:=xlWhole)
strAdresse1 = Zelle.Address
gefunden = False
If Not Zelle Is Nothing Then
Do
'Prüfen ob Artikel auch übereinstimmt
If varArt = wks1.Cells(Zelle.Row, 2) Then
gefunden = True
Exit Do
End If
'Nächsten KST-Eintrag suchen
Set Zelle = wks1.Columns(1).FindNext(after:=Zelle)
Loop Until Zelle.Address = strAdresse1
End If
If gefunden = False Then
With wks2
'Spalten A bis G in Zeile rot markieren
.Range(.Cells(ZeileAlt, 1), .Cells(ZeileAlt, 7)).Interior.ColorIndex = 3
End With
End If
Next
End Sub


Anzeige
@PeterFeustelAWAW: Tabellenvergleich
19.06.2009 22:42:19
Bibo
Hallo Peter,
entschuldige bitte, dass ich mich erst jetzt wieder melde.
Vielen Dank für Deine Unterstützung. Ich habe den Code getestet, klappt bis auf eine Kleinigkeit - Datum eines Datensatzes wird als geändert farblich markiert, obwohl ich tatsächlich keine Abweichung feststellen kann.
Ich habe die Datei jetzt zum Testen an einen Kollegen weiter gegeben. Falls noch etwas am Code anzupasen wäre, hoffe ich, dass ich mich nochmals an dich wenden darf.
Ein schönes Wochenende wünscht Dir
Bibo
Anzeige
;

Forumthreads zu verwandten Themen

Anzeige
Entdecke relevante Threads

Schau dir verwandte Threads basierend auf dem aktuellen Thema an

Alle relevanten Threads mit Inhaltsvorschau entdecken
Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Entdecke mehr
Finde genau, was du suchst

Die erweiterte Suchfunktion hilft dir, gezielt die besten Antworten zu finden

Suche nach den besten Antworten
Unsere beliebtesten Threads

Entdecke unsere meistgeklickten Beiträge in der Google Suche

Top 100 Threads jetzt ansehen
Anzeige