Live-Forum - Die aktuellen Beiträge
Anzeige
Archiv - Navigation
1080to1084
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Inhaltsverzeichnis

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

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

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige