VBA Makro Listenvergleich

DjKaliX · 04.07.2007

Liebe User(innen) !

Mein Chef hat in der Arbeit mir den Auftrag gegeben ein Makro zu schreiben und ich kenn mich nicht so ganz aus.

Das Makro soll ein Vergleichsmakro sein von 2 Sheets.
Es soll beide Sheets durchlaufen und schaun ob sich etwas in einer Zeile verändert hat und wenn ja was!
Es kann aber auch vorkommen das Zeilen im Sheet 2 gelöscht wurden also soll das Makro die nächste Zeile auch noch vergleichen ob nicht vielleicht da die Daten drinnenstehen!

z.B.:

Sheet1:

Name Alter Geschlecht Wohnort
Patrick 16 m Wien
Simon 30 m Brüssel
Stefanie 14 w Klagenfurt
Manuel 56 m Berlin

Sheet2:

Name Alter Geschlecht Wohnort
Patrick 16 m Strasshof
Simon 30 m Brüssel
Manuel 56 m Berlin

Sheet3(Ausgabe):

In Zeile 1 hat sich die Spalte Wohnort von Wien auf Strasshof geändert! (Patrick)
Zeile 2 blieb unverändert!
Zeile 3 wurde gelöscht!
Zeile 4 blieb unverändert!

Ich hoffe mir kann jemand das Makro schreiben wäre wirklich wichtig für mich und hier jetzt noch die Aufgabenstellung die ich von meinem Chef bekommen hab per Mail:

Lieber Patrick,

Beiliegend zwei typische Tabellen, die verglichen werden sollen.

Zwischen den beiden Zeitpunkten können:
- neue Zeilen dazugekommen sein
- Zeilen weggefallen sein
- sich einzelne Felder in Zeilen geändert haben

_____________

Danke für eure Hilfe

lg,
Dj KaliX

Matjes · 04.07.2007

Hallo DjKaliX,

da stellen sich noch einige Fragen:

a) Wie eindeutig sind die Zeilen mit ihrem Inhalt oder können sie auch mehrfach gleich sein ?

also z.B.
Simon 30 m Brüssel
Patrick 16 m Wien
Simon 30 m Brüssel

Oder ist da noch eine feste ID (Ident-Nummer) ?

b) Wieviel Eigenschaften können sich in der Zeile gleichzeitig ändern ?

c) Aussage->Zeile ist unverändert' heißt das die Zeile mit ihrem Inhalt in beiden Blättern enthalten ist. Die Zeilenr kann sich erheblich unterscheiden. Was ist dann mit 2 gleichen Zeilen im 1. Blatt, von denen im 2. Blatt eine gelöscht wird. Welche ist gelöscht worden, die erste oder die 2te ?

Also ganz so einfach ist das mit dem vergleichen nicht.

Man konnte z.B. folgenden Algorithmus wählen:
a) gleiche Zeilen:
zunächst werden zu jeder Zeile in Blatt A eine entsprechende Zeile in Blatt B gesucht. Gesucht wird immer vom Anfang bis zum Ende. Bereits als gleich eingestufte Zeilen werden dabei nicht berücksichtigt.

b) Zeilen mit gleichem Namen,Geschlecht und Alter:
Es werden die noch Zeilen von Blatt A, die nicht durch a) festgelegt sind, mit den von Blatt B ( noch nicht durch a) festgelegt) verglichen.
Wenn Name,Geschlecht und Alter gleich sind, werden die Zeilen als->geänderter Wohnort' festgelegt.

c) Zeilen mit gleichem Namen,Geschlecht und Wohnort:
Es werden die noch Zeilen von Blatt A, die nicht durch a) und b) festgelegt sind, mit den von Blatt B ( noch nicht durch a) und b) festgelegt) verglichen.
Wenn Name,Geschlecht und Wohnort gleich sind, werden die Zeilen als->geändertes Alter' festgelegt.

d) alle Zeilen in Blatt A , die noch nicht zugeordnet sind, werden als->gelöscht' betrachtet.

e) alle Zeilen in Blatt B , die noch nicht zugeordnet sind, werden als->neu' betrachtet.

Gruß Matjes

KaliX · 05.07.2007

Ja der Algorithmus hört sich wirklich gut an, sollte so funktionieren !
Aber mein Problem is der Code wäre wirklich ur nett und wäre dir ur dankbar wenn du das als Code zusammen schreiben könntest natürlich wenn es dir nicht allzuviel Zeit kostet !

Vielen Vielen Dank

Gruß
Dj KaliX

Matjes · 05.07.2007

Hallo KaliX,

dann ist hier erstmal ein Prototyp.

Es wird ein Blatt Alt mit einem Blatt Neu verglichen.
Namen und Spalten kannst du in den Konstanten anpassen.

Gruß Matjes

ps: wenn du mir eine mail an meinen mailaddy schickst, kann ich dir auch die datei schicken.

Code:

Option Explicit

 Private Const cBLATT_ALT = Alt
 Private Const cBLATT_NEU = Neu
 
 Private Const cZ_ERSZTEWERTEZEILE = 2
 Private Const cSP_NAME = 1
 Private Const cSP_ALTER = 2
 Private Const cSP_GESCHLECHT = 3
 Private Const cSP_WOHNORT = 4
 Private Const cSPMAX = cSP_WOHNORT->letzte Spalte
 
 Private Const cFARBE_GLEICH = 35  ->hellgruen
 Private Const cFARBE_GEAENDERT = 36->hellgelb
 Private Const cFARBE_GELOESCHT = 3 ->knallrot
 Private Const cFARBE_NEU = 4    ->knallgruen

Sub TabVerglAltNeu4Spaltig()
 
 Dim wb As Workbook, wsa As Worksheet, wsn As Worksheet
 
 Set wb = ActiveWorkbook
 
 Set wsa = BlattSetzen(wb, cBLATT_ALT)
 If wsa Is Nothing Then GoTo AUFRAEUMEN
 Call BlattBereichFarbeLoeschen(wsa)
 
 Set wsn = BlattSetzen(wb, cBLATT_NEU)
 If wsn Is Nothing Then GoTo AUFRAEUMEN
 Call BlattBereichFarbeLoeschen(wsn)
 
->a) gleiche Zeilen:
->zunächst werden zu jeder Zeile in Blatt A eine entsprechende Zeile in Blatt B gesucht.
->Gesucht wird immer vom Anfang bis zum Ende.
->Bereits als gleich eingestufte Zeilen werden dabei nicht berücksichtigt.
->Gleiche Zeilen werden mit Farbe cFARBE_GLEICH eingefärbt
 Call ZeilenVergleichen(wsa, wsn, cFARBE_GLEICH, cFARBE_GLEICH, 9999)
 
->b) Zeilen mit gleichem Namen,Geschlecht und Alter:
->Es werden die noch Zeilen von Blatt A, die nicht durch a) festgelegt sind,
->mit den von Blatt B ( noch nicht durch a) festgelegt) verglichen.
->Wenn Name,Geschlecht und Alter gleich sind, werden die Zeilen als->geänderter Wohnort' festgelegt.
->Gleiche Zellen werden mit Farbe cFARBE_GLEICH eingefärbt, die geänderte mit cFARBE_GEAENDERT
 Call ZeilenVergleichen(wsa, wsn, cFARBE_GLEICH, cFARBE_GEAENDERT, cSP_WOHNORT)
 
->c) Zeilen mit gleichem Namen,Geschlecht und Wohnort:
->Es werden die noch Zeilen von Blatt A, die nicht durch a) und b) festgelegt sind,
->mit den von Blatt B ( noch nicht durch a) und b) festgelegt) verglichen.
->Wenn Name,Geschlecht und Wohnort gleich sind, werden die Zeilen als->geändertes Alter' festgelegt.
->Gleiche Zellen werden mit Farbe cFARBE_GLEICH eingefärbt, die geänderte mit cFARBE_GEAENDERT
 Call ZeilenVergleichen(wsa, wsn, cFARBE_GLEICH, cFARBE_GEAENDERT, cSP_ALTER)

->d) alle Zeilen in Blatt A , die noch nicht zugeordnet sind, werden als->gelöscht' betrachtet.
->Die Zeilen werden mit Farbe cFARBE_GELOESCHT eingefärbt
 Call NichtbehandelteZeilen(wsa, cFARBE_GELOESCHT)

->e) alle Zeilen in Blatt B , die noch nicht zugeordnet sind, werden als->neu' betrachtet.
->Die Zeilen werden mit Farbe cFARBE_NEU eingefärbt
 Call NichtbehandelteZeilen(wsn, cFARBE_NEU)
 
AUFRAEUMEN:
 Set wb = Nothing: Set wsa = Nothing: Set wsn = Nothing
End Sub

'**********************************************************************
Function NichtbehandelteZeilen(ws As Worksheet, lFarbe As Long)

 Dim lRows As Long, z As Long, c As Long
 
 lRows = ws.Cells(ws.Rows.Count, cSP_NAME).End(xlUp).Row
 For z = cZ_ERSZTEWERTEZEILE To lRows
  If ws.Cells(z, cSP_NAME).Interior.ColorIndex = xlColorIndexNone Then
   For c = 1 To cSPMAX: ws.Cells(z, c).Interior.ColorIndex = lFarbe: Next
  End If
 Next
End Function

'**********************************************************************
Function ZeilenVergleichen(wsa As Worksheet, _
              wsn As Worksheet, _
              lFarbe As Long, _
              lFarbe2 As Long, _
              lSP_NichtPruefen As Long)
 
 Dim lRowsa As Long, za As Long, lRowsn As Long, zn As Long, c As Long
 Dim bGleich As Boolean
 
 lRowsa = wsa.Cells(wsa.Rows.Count, cSP_NAME).End(xlUp).Row
 lRowsn = wsn.Cells(wsn.Rows.Count, cSP_NAME).End(xlUp).Row
 
 For za = cZ_ERSZTEWERTEZEILE To lRowsa
  If wsa.Cells(za, cSP_NAME).Interior.ColorIndex = xlColorIndexNone Then
   For zn = cZ_ERSZTEWERTEZEILE To lRowsn
    If (wsn.Cells(zn, cSP_NAME).Interior.ColorIndex = xlColorIndexNone) Then
     
     bGleich = True
     For c = 1 To cSPMAX
      If wsa.Cells(za, c).Value &lt;> wsn.Cells(zn, c).Value Then
       If c &lt;> lSP_NichtPruefen Then bGleich = False: Exit For
      End If
     Next
     
     If bGleich Then
     ->gleich Zeilen gefunden -> beide mit FARBE_GLEICH anpinseln
      For c = 1 To cSPMAX
       With wsn.Cells(zn, c).Interior
        If c &lt;> lSP_NichtPruefen Then .ColorIndex = lFarbe Else .ColorIndex = lFarbe2
       End With
       With wsa.Cells(za, c).Interior
        If c &lt;> lSP_NichtPruefen Then .ColorIndex = lFarbe Else .ColorIndex = lFarbe2
       End With
      Next
     End If
     
    End If
   Next
  End If
 Next
 
End Function

'**********************************************************************
Function BlattBereichFarbeLoeschen(ws As Worksheet)

 Dim lRowsMax As Long, lRows As Long, lCols As Long, c As Long
 
 lCols = ws.UsedRange.Column + ws.UsedRange.Columns.Count - 1
 
 lRowsMax = 0
 For c = 1 To lCols
  lRows = ws.Cells(ws.Rows.Count, c).End(xlUp).Row
  If lRowsMax &lt; lRows Then lRowsMax = lRows
 Next
 
 ws.Range(ws.Cells(cZ_ERSZTEWERTEZEILE, 1), _
      ws.Cells(lRowsMax, lCols)).Interior.ColorIndex = xlColorIndexNone
 
End Function

'**********************************************************************
Function BlattSetzen(wb As Workbook, sBlattname As String) As Worksheet

 Dim ws As Worksheet
 
 Set BlattSetzen = Nothing
 On Error Resume Next
 Set ws = wb.Worksheets(sBlattname)
 On Error GoTo 0
 If ws Is Nothing Then
  MsgBox  Blatt-> &amp; sBlattname &amp;-> ist nicht erreichbar.
  Exit Function
 End If
 
 Set BlattSetzen = ws: Set ws = Nothing
End Function

KaliX · 06.07.2007

Vielen Vielen Dank dass du dir soviel Mühe gegeben hast !!

Das oben war nur ein Beispiel mit dem Namen Geb. Datum usw. aber ich versuchs auf die Tabelle umzuschreiben die ich habe leider kann ich sie nicht Posten weil da vertrauliche Daten drinnstehen!

Aber wirklich ur nett von dir !!

lg,
KaliX

KaliX · 06.07.2007

Was muss ich den ändern dass das ganze für mehr Spalten funktioniert ansonsten funktionerts einwandfrei wirklich gut !!

Aber meine Tabelle die ich bekommen hab hat mehr Spalten desshalb muss ich das irgendwie ändern !!

lg

Matjes · 06.07.2007

Kommt heute Abend.

Gruß Matjes

Matjes · 07.07.2007

Hallo KaliX,

so jetzt die Lösung für mehrere Spalten. In der Konstante cSP_MAX müßtest du noch die letzte Spalte einstellen, die mit verglichen/farbig gekennzeichnet werden soll.

Ansonsten ist der Algorithmus so angelegt, daß er die ähnlichsten Zeilen einander zuordnet, wobei NAME, GESCHLECHT gleich sein muß.
Alles was nicht zuzuordnen ist, wird als GELÖSCHT bzw. NEU interpretiert. Es wird immer vom Anfang der Liste nach dem ähnlichsten Paar gesucht.

Gruß Matjes

Code:

Option Explicit

 Private Const cBLATT_ALT = Alt
 Private Const cBLATT_NEU = Neu
 
 Private Const cZ_ERSZTEWERTEZEILE = 2
 Private Const cSP_NAME = 1
 Private Const cSP_GESCHLECHT = 3
 
 Private Const cSP_MAX = 7->Vergleich soll bis zu Spalte G gehen
 
 Private Const cFARBE_GLEICH = 35 ->hellgruen
 Private Const cFARBE_GEAENDERT = 36->hellgelb
 Private Const cFARBE_GELOESCHT = 3->knallrot
 Private Const cFARBE_NEU = 4   ->knallgruen

Sub TabVerglAltNeuMehrSpaltig()
 
 Dim wb As Workbook, wsa As Worksheet, wsn As Worksheet
 
 Set wb = ActiveWorkbook
 
 Set wsa = BlattSetzen(wb, cBLATT_ALT)
 If wsa Is Nothing Then GoTo AUFRAEUMEN
 Call BlattBereichFarbeLoeschen(wsa)
 
 Set wsn = BlattSetzen(wb, cBLATT_NEU)
 If wsn Is Nothing Then GoTo AUFRAEUMEN
 Call BlattBereichFarbeLoeschen(wsn)
 
->a) gleiche Zeilen:
->zunächst werden zu jeder Zeile in Blatt A eine entsprechende Zeile in Blatt B gesucht.
->Gesucht wird immer vom Anfang bis zum Ende.
->Bereits als gleich eingestufte Zeilen werden dabei nicht berücksichtigt.
->Gleiche Zeilen werden mit Farbe cFARBE_GLEICH eingefärbt
->b) Zeilen mit gleichem Namen,Geschlecht aber mit geänderte(n) Eigenschaft(en)
->Es werden die Zeilen von Blatt A, die nicht festgelegt sind,
->mit den von Blatt B noch nicht festgelegten verglichen.
->Wenn Name,Geschlecht müssen gleich sein.
->Es wird zunächst versucht Zeilen zu finden die nur 1 Abweichung haben.
->Wenn keine mehr gefunden wird, wird nach 2 Abweichungen geschaut,
->usw. bis nur noch Name und Geschlecht gleich sind.
->
->Gleiche Zellen werden mit Farbe cFARBE_GLEICH eingefärbt, die geänderte mit cFARBE_GEAENDERT.
 Call ZeilenVergleichen(wsa, wsn, cFARBE_GLEICH, cFARBE_GEAENDERT)

->d) alle Zeilen in Blatt A , die noch nicht zugeordnet sind, werden als->gelöscht' betrachtet.
->Die Zeilen werden mit Farbe cFARBE_GELOESCHT eingefärbt
 Call NichtbehandelteZeilen(wsa, cFARBE_GELOESCHT)

->e) alle Zeilen in Blatt B , die noch nicht zugeordnet sind, werden als->neu' betrachtet.
->Die Zeilen werden mit Farbe cFARBE_NEU eingefärbt
 Call NichtbehandelteZeilen(wsn, cFARBE_NEU)
 
AUFRAEUMEN:
 Set wb = Nothing: Set wsa = Nothing: Set wsn = Nothing
End Sub
'**********************************************************************
Function ZeilenVergleichen(wsa As Worksheet, wsn As Worksheet, _
             lFarbeOK As Long, lFarbeDIFF As Long)
  
 Dim lRowsa As Long, za As Long, lRowsn As Long, zn As Long, c As Long
 Dim lX As Long, lGleicheGesucht As Long, lGleichAnz As Long
 Dim lFarbe As Long
 
 lRowsa = wsa.Cells(wsa.Rows.Count, cSP_NAME).End(xlUp).Row
 lRowsn = wsn.Cells(wsn.Rows.Count, cSP_NAME).End(xlUp).Row
 
 For lX = 0 To cSP_MAX
  lGleicheGesucht = cSP_MAX - lX
  For za = cZ_ERSZTEWERTEZEILE To lRowsa
   If wsa.Cells(za, cSP_NAME).Interior.ColorIndex = xlColorIndexNone Then
    For zn = cZ_ERSZTEWERTEZEILE To lRowsn
     If (wsn.Cells(zn, cSP_NAME).Interior.ColorIndex = xlColorIndexNone) Then
     ->feste Schlüssel sind Name und geschlecht,d.h. die müssen gleich sein
      If (wsa.Cells(za, cSP_NAME).Value = wsn.Cells(zn, cSP_NAME).Value) And _
       (wsa.Cells(za, cSP_GESCHLECHT).Value = wsn.Cells(zn, cSP_GESCHLECHT).Value) Then
       
       lGleichAnz = 2->
       For c = 1 To cSP_MAX
        If (c &lt;> cSP_NAME) And (c &lt;> cSP_GESCHLECHT) Then
         If wsa.Cells(za, c).Value = wsn.Cells(zn, c).Value Then
          lGleichAnz = lGleichAnz + 1
         End If
        End If
       Next
       If (lGleicheGesucht = lGleichAnz) Then
       ->Zeilen mit gesuchter Anzahl gleicher Zellen gefunden -> anpinseln
        For c = 1 To cSP_MAX
         If (c = cSP_NAME) Or (c = cSP_GESCHLECHT) Then
          lFarbe = lFarbeOK
         Else
          If wsa.Cells(za, c).Value = wsn.Cells(zn, c).Value Then
           lFarbe = lFarbeOK
          Else
           lFarbe = lFarbeDIFF
          End If
         End If
         wsn.Cells(zn, c).Interior.ColorIndex = lFarbe
         wsa.Cells(za, c).Interior.ColorIndex = lFarbe
        Next
       End If
      End If
     End If
    Next
   End If
  Next
 Next
End Function

'**********************************************************************
Function NichtbehandelteZeilen(ws As Worksheet, lFarbe As Long)

 Dim lRows As Long, z As Long, c As Long
 
 lRows = ws.Cells(ws.Rows.Count, cSP_NAME).End(xlUp).Row
 For z = cZ_ERSZTEWERTEZEILE To lRows
  If ws.Cells(z, cSP_NAME).Interior.ColorIndex = xlColorIndexNone Then
   For c = 1 To cSP_MAX: ws.Cells(z, c).Interior.ColorIndex = lFarbe: Next
  End If
 Next
End Function

'**********************************************************************
Function BlattBereichFarbeLoeschen(ws As Worksheet)

 Dim lRowsMax As Long, lRows As Long, lCols As Long, c As Long
 
 lCols = ws.UsedRange.Column + ws.UsedRange.Columns.Count - 1
 
 lRowsMax = 0
 For c = 1 To lCols
  lRows = ws.Cells(ws.Rows.Count, c).End(xlUp).Row
  If lRowsMax &lt; lRows Then lRowsMax = lRows
 Next
 
 ws.Range(ws.Cells(cZ_ERSZTEWERTEZEILE, 1), _
     ws.Cells(lRowsMax, lCols)).Interior.ColorIndex = xlColorIndexNone
 
End Function

'**********************************************************************
Function BlattSetzen(wb As Workbook, sBlattname As String) As Worksheet

 Dim ws As Worksheet
 
 Set BlattSetzen = Nothing
 On Error Resume Next
 Set ws = wb.Worksheets(sBlattname)
 On Error GoTo 0
 If ws Is Nothing Then
  MsgBox  Blatt-> &amp; sBlattname &amp;-> ist nicht erreichbar.
  Exit Function
 End If
 
 Set BlattSetzen = ws: Set ws = Nothing
End Function

VBA Makro Listenvergleich

DjKaliX

Matjes

KaliX

Matjes

KaliX

KaliX

Matjes

Matjes

VBA Makro Listenvergleich

ANGEBOTE & SPONSOREN

Neueste Themen

Statistik des Forums