VBA Makro Listenvergleich

Dieses Thema VBA Makro Listenvergleich im Forum "Microsoft Office Suite" wurde erstellt von DjKaliX, 4. Juli 2007.

Thema: VBA Makro Listenvergleich Liebe User(innen) ! Mein Chef hat in der Arbeit mir den Auftrag gegeben ein Makro zu schreiben und ich kenn mich...

  1. 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
     
  2. 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 :)
     
  3. 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
     
  4. 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 <> wsn.Cells(zn, c).Value Then
           If c <> 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 <> lSP_NichtPruefen Then .ColorIndex = lFarbe Else .ColorIndex = lFarbe2
           End With
           With wsa.Cells(za, c).Interior
            If c <> 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 < 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-> & sBlattname &-> ist nicht erreichbar.
      Exit Function
     End If
     
     Set BlattSetzen = ws: Set ws = Nothing
    End Function
     
  5. 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
     
  6. 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
     
  7. Kommt heute Abend.

    Gruß Matjes :)
     
  8. 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 <> cSP_NAME) And (c <> 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 < 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-> & sBlattname &-> ist nicht erreichbar.
      Exit Function
     End If
     
     Set BlattSetzen = ws: Set ws = Nothing
    End Function
     
Die Seite wird geladen...

VBA Makro Listenvergleich - Ähnliche Themen

Forum Datum
Excel VBA Makro zum suchen eines Textes und anschließend einen Breich zu kopieren Microsoft Office Suite 22. Jan. 2015
Word 2013 VBA: Makro aus einer anderen Datei aufrufen Microsoft Office Suite 16. Juni 2014
Excel VBA Makro zum suchen und markieren von Zeilen die ein bestimmtes Wort enthalten Microsoft Office Suite 16. Juni 2014
Excel: Makro ASCII verschieben Windows XP Forum 8. Nov. 2013
Makros und anderes - Excel Microsoft Office Suite 15. März 2013