2 Excel Dateien vergleichen

[Egon12]

Hallo Jochen,

da man davon ausgehen muss, dass die Listen recht groß sein können und du eh nach einer automatisierten Lösung gefragt hast ist VBA der praktikabelste Weg.

In ein allgemeines Modul:

Code:

Option Explicit
    Private arrE(), arrA(), PfadE$, PfadA$

Sub UeberpuefungStarten()
    PfadE = ThisWorkbook.Path & "\" & "Wareneingang.xlsx"   'ggf. Anpassen
    If PfadE = "" Then MsgBox "Wareneingang auswählen": Call PfadLesen(PfadE)
    Call DateiLesen(PfadE, arrE)
    PfadA = ThisWorkbook.Path & "\" & "Warenausgang.xlsx"   'ggf. Anpassen
    If PfadA = "" Then MsgBox "Warenausgang auswählen": Call PfadLesen(PfadA)
    Call DateiLesen(PfadA, arrA)
    Abgleichen
End Sub

Private Sub Abgleichen()
    Dim i&, j&, k&, iA&, iE&, dic As Object, arrArt, tmpE(), tmpA(), arrTab()
    Set dic = CreateObject("Scripting.Dictionary")
    For i = LBound(arrA) + 2 To UBound(arrA)
        dic(arrA(i, 3)) = 0
    Next
    For i = LBound(arrE) + 2 To UBound(arrE)
        dic(arrE(i, 3)) = 0
    Next
    arrArt = dic.keys
    ReDim arrTab(1 To UBound(arrArt) + 1, 1 To UBound(arrA, 2))
    For i = LBound(arrArt) To UBound(arrArt)
        For j = LBound(arrE) + 2 To UBound(arrE)
            If arrArt(i) = arrE(j, 3) Then iE = j: Exit For
        Next j
        For j = LBound(arrA) + 2 To UBound(arrA)
            If arrArt(i) = arrA(j, 3) Then iA = j: Exit For
        Next j
        If iE > 0 Then
            ReDim tmpE(1 To 1, 1 To UBound(arrE, 2))
            For j = LBound(arrE, 2) To UBound(arrE, 2)
                tmpE(1, j) = arrE(iE, j)
            Next j
        End If
        If iA > 0 Then
            ReDim tmpA(1 To 1, 1 To UBound(arrA, 2))
            For j = LBound(arrA, 2) To UBound(arrA, 2)
                tmpA(1, j) = arrA(iA, j)
            Next j
        End If
        k = k + 1
        For j = LBound(arrE, 2) To UBound(arrE, 2)
            If j <> 4 Then
                arrTab(k, j) = tmpE(1, j)
            Else
                If iE = 0 Then
                    arrTab(k, j) = "Ausgang: " & tmpA(1, j) & " / Artikel nicht angeliefert"
                Else
                    If tmpE(1, 4) <> tmpA(1, 4) Then
                        arrTab(k, j) = "Ausgang: " & tmpA(1, j) & " / Eingang: " & tmpE(1, j)
                    Else
                        arrTab(k, j) = tmpE(1, j)
                    End If
                End If
            End If
        Next j
        iA = 0: iE = 0
    Next i
    With Tabelle1.ListObjects(1)
        If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
        .ListRows.Add.Range.Resize(UBound(arrTab), 6) = arrTab
    End With
End Sub


Private Function PfadLesen(pfad As String) As String
    Dim objFdl As Variant
    Set objFdl = Application.FileDialog(msoFileDialogOpen)
    With objFdl
        .AllowMultiSelect = False
        .Show
        If .SelectedItems.Count = 0 Then Exit Function
        pfad = .SelectedItems.Item(1)
        PfadLesen = pfad
    End With
End Function

Private Function DateiLesen(vPfad As String, arrRet As Variant) As Variant
    Dim oDatei$, arr()
    Application.Workbooks.Open (vPfad)
    Application.ScreenUpdating = False
    oDatei = Mid(vPfad, InStrRev(vPfad, "\") + 1, Len(vPfad))

    arr = Workbooks(oDatei).Sheets(1).UsedRange.Value
    Application.Workbooks(oDatei).Close
    Application.ScreenUpdating = True
    arrRet = arr
End Function

Die Ausgabe erfolgt über ein Listobjekt (Intelligente Tabelle).

  Kontrolle.xlsm (Größe: 22,24 KB / Downloads: 1)

Gruß Uwe

---

Ach ja fast vergessen:

Mit bedingter Formatierung kann man die differrierenden/auffälligen Datensätze einzufärben.
Formel: =ISTTEXT($D3)

Gruß Uwe