Excel Dateien vergleichen

Dieses Thema Excel Dateien vergleichen im Forum "Microsoft Office Suite" wurde erstellt von lummo, 30. Juni 2008.

Thema: Excel Dateien vergleichen Hallo Gemeinde, in Word gibt es die Möglichkeit, zwei verschiedene Dokumente auf Änderungen zu vergleichen. Kann...

  1. Hallo Gemeinde,

    in Word gibt es die Möglichkeit, zwei verschiedene Dokumente auf Änderungen zu vergleichen. Kann Excel sowas auch? Eine Grund-Datei als Ausgangsdokument und die angepassten Dateien so vergleichen lassen, dass ich Änderungen erkennen kann. Am besten wäre natürlich, wenn die entsprechenden Zellen angezeigt würden, in denen beispielsweise die Formel geändert wurde, sie aber das selbe anzeigt. Beispiel =a1+a2+a3+a4 rechnet das selbe wie =summe(a1:a4) aber es ist was anderes eingegeben worden.

    lummo
     
  2. Hallo lummo,

    mit dem folgenden Makro sollte das Vergleichen so in die Richtung gehen, wie du es dir vorstellst.
    (ab Excel 2003 sollte es funktionieren).

    2 Dateien auswählen - Name muss unterschiedlich sein !
    Es wird eine Differenz-Protokoll-datei erzeugt, in der du die unterschieden Zeilen jeweils untereinanderkopiert werden und die Unterschiede farblich gekennzeichnet werden.
    -> gelb - nur Value unterschiedlich
    -> blau - nur Formel unterschiedlich
    -> orage - Formel und Value unterschiedlich

    Dazu werden ausgegeben: Blattname, Zeile, Unterschied in Formel, Unterschied in Value

    Probier's mal aus.

    Gruß Matjes :)
    Code:
    Option Explicit
    'ab EXCEL 2003
    
    Sub ZweiMappenVergleichen()
     Dim wb1 As Workbook, ws1 As Worksheet, bwb1SchonOffen As Boolean
     Dim wb2 As Workbook, ws2 As Worksheet, bwb2SchonOffen As Boolean
     Dim sDateiNameFull1 As String, sPfad1 As String, sDateiName1 As String
     Dim sDateiNameFull2 As String, sPfad2 As String, sDateiName2 As String
     
     If Not EineXLSDateiAuswaehlen(1. Datei auswählen, sDateiNameFull1, sPfad1, sDateiName1) Then Exit Sub
     If Not EineXLSDateiAuswaehlen(2. Datei auswählen, sDateiNameFull2, sPfad2, sDateiName2) Then Exit Sub
     If sDateiName1 = sDateiName2 Then MsgBox 2 Dateien mit gleichem Namen geht nicht.: Exit Sub
     
     If Not EineDateiZumLesenOeffnen(sPfad1, sDateiName1, wb1, bwb1SchonOffen) Then Exit Sub
     If Not EineDateiZumLesenOeffnen(sPfad2, sDateiName2, wb2, bwb2SchonOffen) Then Exit Sub
     
     If Not ZweiDateienBlaetterEigenschaftenVergleichen(wb1, wb2) Then Exit Sub
     
     Call ZweiDateienBlaetterVergleichen(wb1, wb2)
     
    End Sub
    '*************************************************************************************************************
    Private Function ZweiDateienBlaetterVergleichen(wbx As Workbook, wby As Workbook)
    ->Liefert eine Protokolldatei der Differenzen. Der Vergleich erfolgt Zeilenweise.
    ->Wird ein Unterschied festgestellt, so werden
    -> - Blattname
    -> - Zeilenr
    -> - Art des Unterschiedes: Value und/oder Formel
    -> die Zeile aus x
    -> die Zeile aus y
    -> Die unterschiedlichen Zellen werden farblich markiert
    -> gelb - nur Value    unterschiedlich
     Const cFARBIND_VALUE = 36     ->hellgelb
    -> blau - nur Formel    unterschiedlich
     Const cFARBIND_FORMEL = 34     ->hellblau
    -> orage - Formel und Value unterschiedlich
     Const cFARBIND_FORMEL_UND_VALUE = 40->orange
    ->
    -> Pro Blatt ist die Anzahl der angezeigten unterschiedlichen Zeilen auf 300 begrenzt
     Const cANZMAX_PROBLATT = 300
    ->
    -> Bei mehr als 3000 Unterschieden insgesamt ist Schluß
     Const cANZMAX_GESAMT = 3000
    ->
     Const cSP_Blattname = 1
     Const cSP_Zeile = cSP_Blattname + 1
     Const cSP_DiffValue = cSP_Zeile + 1
     Const cSP_DiffFormel = cSP_DiffValue + 1
     Const cSP_AnfangZeile = cSP_DiffFormel + 1
     
     Dim wbz As Workbook, wsz As Worksheet, wsx As Worksheet, wsy As Worksheet
     Dim lDiff_Gesamt As Long, lDiff_Blatt As Long
     Dim lRowsx As Long, lColsx As Long, lRowsy As Long, lColsy As Long, lRows As Long, lCols As Long
     Dim c As Long, r As Long, x As Long, z As Long
     Dim lDiff_Cols_Value() As Boolean, lDiff_Cols_Formel() As Boolean
     Dim bFormelx As Boolean, bFormely As Boolean, bDiffCols_value As Boolean, bDiffCols_formel As Boolean
     
    ->Protokoll-Datei mit Protokoll-Blatt, Text-Format
     Set wbz = Workbooks.Add
     Application.DisplayAlerts = False
     For x = wbz.Worksheets.Count To 2 Step -1: wbz.Worksheets(x).Delete: Next
     Application.DisplayAlerts = True
     Set wsz = wbz.Worksheets(1)
     wsz.Cells.NumberFormat = @
     z = 1
     wsz.Rows(1).Cells.Font.Bold = True
     wsz.Cells.HorizontalAlignment = xlLeft
     wsz.Cells.VerticalAlignment = xlTop
     wsz.Cells(z, cSP_Blattname).Value = Blattname
     wsz.Cells(z, cSP_Zeile).Value = Zeile
     wsz.Cells(z, cSP_DiffValue).Value = Diff & vbLf & Value
     wsz.Cells(z, cSP_DiffFormel).Value = Diff & vbLf & Formel
      
     
     lDiff_Gesamt = 0
     For Each wsx In wbx.Worksheets
      lRowsx = wsx.UsedRange.Rows.Count + wsx.UsedRange.Row - 1
      lColsx = wsx.UsedRange.Columns.Count + wsx.UsedRange.Column - 1
      
      Set wsy = wby.Worksheets(wsx.Name)
      lRowsy = wsy.UsedRange.Rows.Count + wsy.UsedRange.Row - 1
      lColsy = wsy.UsedRange.Columns.Count + wsy.UsedRange.Column - 1
     
      If lRowsx < lRowsy Then lRows = lRowsy Else lRows = lRowsx
      If lColsx < lColsy Then lCols = lColsy Else lCols = lColsx
      
      lDiff_Blatt = 0
     ->zu vergleichender Bereich LRows, lCols
      For r = 1 To lRows
       ReDim lDiff_Cols_Value(1 To lCols)
       ReDim lDiff_Cols_Formel(1 To lCols)
       bDiffCols_value = False
       bDiffCols_formel = False
       For c = 1 To lCols
        
       ->Value gleich ?
        If wsx.Cells(r, c).Value <> wsy.Cells(r, c).Value Then lDiff_Cols_Value(c) = True: bDiffCols_value = True
       ->Formel gleich ?
        bFormelx = wsx.Range(wsx.Cells(r, c), wsx.Cells(r, c)).HasFormula
        bFormely = wsy.Range(wsy.Cells(r, c), wsy.Cells(r, c)).HasFormula
        If bFormelx <> bFormelx Then lDiff_Cols_Formel(c) = True: bDiffCols_formel = True
        If bFormelx And bFormely Then
         If wsx.Cells(r, c).Formula <> wsy.Cells(r, c).Formula Then lDiff_Cols_Formel(c) = True: bDiffCols_formel = True
        End If
       Next
       
      ->Differenzen ?
       If bDiffCols_value Or bDiffCols_formel Then
       ->ZeilenDifferenz auf Protokoll-Datei ausgeben
        z = z + 1
        wsz.Cells(z, cSP_Blattname).Value = wsx.Name
        wsz.Cells(z, cSP_Zeile).Value = r
        If bDiffCols_value Then wsz.Cells(z, cSP_DiffValue).Value = x
        If bDiffCols_formel Then wsz.Cells(z, cSP_DiffFormel).Value = x
       ->betroffene Zeilenn kopieren
        z = z + 1
        wsx.Range(wsx.Cells(r, 1), wsx.Cells(r, lCols)).Copy
        wsz.Cells(z, cSP_AnfangZeile).PasteSpecial _
                         Paste:=xlPasteAll, _
                         Operation:=xlNone, _
                         SkipBlanks:=False, _
                         Transpose:=False
        z = z + 1
        wsy.Range(wsy.Cells(r, 1), wsy.Cells(r, lCols)).Copy
        wsz.Cells(z, cSP_AnfangZeile).PasteSpecial _
                         Paste:=xlPasteAll, _
                         Operation:=xlNone, _
                         SkipBlanks:=False, _
                         Transpose:=False
       ->unterschiedliche Zellen farblich kennzeichnen
        For x = 1 To lCols
         If lDiff_Cols_Formel(x) And lDiff_Cols_Value(x) Then
          wsz.Cells(z, cSP_AnfangZeile + x - 1).Interior.ColorIndex = cFARBIND_FORMEL_UND_VALUE
          wsz.Cells(z - 1, cSP_AnfangZeile + x - 1).Interior.ColorIndex = cFARBIND_FORMEL_UND_VALUE
         ElseIf lDiff_Cols_Formel(x) Then
          wsz.Cells(z, cSP_AnfangZeile + x - 1).Interior.ColorIndex = cFARBIND_FORMEL
          wsz.Cells(z - 1, cSP_AnfangZeile + x - 1).Interior.ColorIndex = cFARBIND_FORMEL
         ElseIf lDiff_Cols_Value(x) Then
          wsz.Cells(z, cSP_AnfangZeile + x - 1).Interior.ColorIndex = cFARBIND_VALUE
          wsz.Cells(z - 1, cSP_AnfangZeile + x - 1).Interior.ColorIndex = cFARBIND_VALUE
         End If
        Next
        
       ->Differenzenzähler
        lDiff_Blatt = lDiff_Blatt + 1
        lDiff_Gesamt = lDiff_Gesamt + 1
        If lDiff_Gesamt >= cANZMAX_GESAMT Then GoTo AUFRAEUMEN
        If lDiff_Blatt >= cANZMAX_PROBLATT Then Exit For
        
       End If
       
      Next
     Next
    AUFRAEUMEN:
     If lDiff_Gesamt = 0 Then
      wbz.Close SaveChanges:=False: MsgBox Keine Unterschiede vorhanden.
     Else
      For x = 1 To cSP_AnfangZeile - 1: wsz.Columns(x).AutoFit: Next
     End If
     Set wsx = Nothing: Set wsy = Nothing: Set wsz = Nothing: Set wbz = Nothing
    End Function
    
    '*************************************************************************************************************
    Private Function ZweiDateienBlaetterEigenschaftenVergleichen(wbx As Workbook, wby As Workbook) As Boolean
    ->liefert true, wenn jeder Blattname der einen Datei auch in der anderen enthalten ist
    ->und jeweils beide Blätter die gleiche->sichtbar' Eigenschaft haben
     Dim wsx As Worksheet, wsy As Worksheet
     Dim sMx() As String, sMxCnt As Long: ReDim sMx(1 To 1)
     Dim sVisibleX As String, sVisibleY As String
     Dim bFound As Boolean
     Dim x As Long
     
     For Each wsx In wbx.Worksheets
      bFound = False
      For Each wsy In wby.Worksheets
       If LCase(wsy.Name) = LCase(wsx.Name) Then
        bFound = True
        If wsx.Visible <> wsy.Visible Then
         Select Case wsy.Visible
          Case xlSheetHidden:   sVisibleY = versteckt
          Case xlSheetVeryHidden: sVisibleY = ganz versteckt
          Case xlSheetVisible:   sVisibleY = sichtbar
         End Select
         Select Case wsx.Visible
          Case xlSheetHidden:   sVisibleX = versteckt
          Case xlSheetVeryHidden: sVisibleX = ganz versteckt
          Case xlSheetVisible:   sVisibleX = sichtbar
         End Select
         sMxCnt = sMxCnt + 1: ReDim Preserve sMx(1 To sMxCnt)
         sMx(sMxCnt) = Blatt:  & wsx.Name & vbLf & _
                in Datei:  & wbx.Name &   & sVisibleX & vbLf & _
                in Datei:  & wby.Name &   & sVisibleY
        End If
        Exit For
       End If
      Next
      If Not bFound Then
       sMxCnt = sMxCnt + 1: ReDim Preserve sMx(1 To sMxCnt)
       sMx(sMxCnt) = _
        Datei:  & wbx.Name &  Blatt:  & wsx.Name & vbLf & _
        in Datei:  & wby.Name &  nicht vorhanden.
      End If
     Next
     For Each wsy In wby.Worksheets
      bFound = False
      For Each wsx In wbx.Worksheets
       If LCase(wsy.Name) = LCase(wsx.Name) Then bFound = True: Exit For
      Next
      If Not bFound Then
       sMxCnt = sMxCnt + 1: ReDim Preserve sMx(1 To sMxCnt)
       sMx(sMxCnt) = _
        Datei:  & wby.Name &  Blatt:  & wsy.Name & vbLf & _
        in Datei:  & wbx.Name &  nicht vorhanden.
      End If
     Next
     
     If sMxCnt > 0 Then
      MsgBox Beim Vergleich der Blattnamen und Eigenschaften sind  & sMxCnt &  Unterschiede erkannt worden.
      For x = 1 To sMxCnt: MsgBox sMx(x): Next
     Else
      ZweiDateienBlaetterEigenschaftenVergleichen = True
     End If
    AUFRAEUMEN:
     Set wsx = Nothing: Set wsy = Nothing
    End Function
    
    '*************************************************************************************************************
    Private Function EineDateiZumLesenOeffnen(sPfad As String, _
                         sDateiname As String, _
                         wb As Workbook, _
                         bwbSchonOffen) As Boolean
    
    ->pruefen, ob Datei bereits geöffnet ist
     Dim wbx As Workbook
     
     For Each wbx In Workbooks
      If wbx.Name = sDateiname Then
       Set wb = wbx
       bwbSchonOffen = True
       EineDateiZumLesenOeffnen = True
       GoTo AUFRAEUMEN
      End If
     Next
     
     bwbSchonOffen = False
     On Error Resume Next
     Set wb = Nothing
     Set wb = Workbooks.Open( _
          Filename:=sPfad & Application.PathSeparator & sDateiname, _
          UpdateLinks:=False, _
          ReadOnly:=True)
     On Error GoTo 0
     
     If wb Is Nothing Then
      MsgBox _
       Datei konnte nicht geöffnet werden. & vbLf & _
       sPfad & Application.PathSeparator & sDateiname
      GoTo AUFRAEUMEN
     End If
     
     EineDateiZumLesenOeffnen = True
    AUFRAEUMEN:
     Set wbx = Nothing
    End Function
    
    
    '*************************************************************************************************************
    Private Function EineXLSDateiAuswaehlen(sTitel As String, _
                        sDateiNameFull As String, _
                        sPfad As String, _
                        sDateiname As String) As Boolean
     Dim oDlgOpen   As FileDialog
     Dim sTmp() As String
     
     Set oDlgOpen = Application.FileDialog(msoFileDialogFilePicker)
    ->msoFileDialogOpen, msoFileDialogSaveAs, msoFileDialogFolderPicker, msoFileDialogFilePicker,
     oDlgOpen.AllowMultiSelect = False
     oDlgOpen.Filters.Clear
     oDlgOpen.Filters.Add EXCEL, *.xls, 1
     oDlgOpen.InitialView = msoFileDialogViewList->msoFileDialogViewDetails
     oDlgOpen.Title = Datei auswählen
     oDlgOpen.Show
     If oDlgOpen.SelectedItems.Count = 0 Then GoTo AUFRAEUMEN
      
     sDateiNameFull = oDlgOpen.SelectedItems(1)
     sTmp = Split(sDateiNameFull, Application.PathSeparator)
     sDateiname = sTmp(UBound(sTmp()))
     sPfad = Left(sDateiNameFull, Len(sDateiNameFull) - Len(sDateiname))
     If Right(sPfad, 1) = Application.PathSeparator Then sPfad = Left(sPfad, Len(sPfad) - 1)
          
     EineXLSDateiAuswaehlen = True
    AUFRAEUMEN:
     Set oDlgOpen = Nothing
    End Function
     
  3. Serwas Matjes,

    funzt vom System her tadellos. Nur kann ich nicht direkt vergleichen, weil einige meiner Vergleichsdokumente eine zusätzliche Zeile eingefügt bekommen haben, für den Namen des Bearbeiters und seine Kennziffern (unterschiedlich viel). So ist zwar der Inhalt gleich aber durch die verschobene Zeile nicht vergleichbar.

    Ich werd das dann halt manuell anpassen und mit deinem Makro vergleichen.

    Vielen Dank für die Mühen,

    derlummo
     
Die Seite wird geladen...

Excel Dateien vergleichen - Ähnliche Themen

Forum Datum
Bestimmter User kann seine Excel Dateien nicht mehr direkt öffnen Software: Empfehlungen, Gesuche & Problemlösungen 16. Apr. 2016
Öffnen mit Doppelklick funktioniert bei Word u. Excel Dateien nichtmehr Microsoft Office Suite 10. Feb. 2015
Excel-Dateien bearbeiten auf iPhone Windows XP Forum 10. Sep. 2013
Excel Dateien im Internet Explorer öffnen funktioniert nicht, trotz Registry-Eintrag Microsoft Office Suite 22. Juli 2013
Office 2003 und 2010 Paralellinstallatin, mehrer xls-Dateien Excel 2003 zuweisen Windows XP Forum 13. Juli 2012