Hallo,

in dieser ZIP-Datei befinden sich folgende Arbeitsmappen:

• Kunden.xlsx mit Beispiel-Daten
• Abgleich - 2017-07.xlsx mit Beispiel-Abgleichsdaten für den Juli 2017
• Analyse.xlsm Mit einem Auswerungs-Makro

Das Auswertungs-Makro liest alle beiden xlsx-Arbeitsmappen ein und stellt die Angaben in der gewünschten Form gegenüber:

Option Explicit

Private Const MONEYFORMAT = "_-* #,##0.00 [$€-407]_-;-* #,##0.00 [$€-407]_-;_-* ""-""?? [$€-407]_-;_-@_-"
Private Const PERCENTFORMAT = "0.00%"

Sub Analyse()
    Dim wbkNew As Workbook, wbkKd As Workbook, wbkLast As Workbook
    Dim wshNew As Worksheet, wshKd As Worksheet, wshLast As Worksheet
    
    Dim colWorkbookOpened As New Collection
    
    ' Analyse in dieser Arbeitsmappe erstellen
    Set wbkNew = ThisWorkbook
    Set wshNew = wbkNew.Worksheets(1)
    
    ' Arbeitsmappe Kunden
    Set wbkKd = GetWorkbook(ThisWorkbook.Path & "\Kunden.xlsx", colWorkbookOpened)
    Set wshKd = wbkKd.Worksheets(1)
    
    ' Arbeitsmappe Letzter Abgleich
    Set wbkLast = GetWorkbook(ThisWorkbook.Path & "\Abgleich - " & LastMonth & ".xlsx", colWorkbookOpened)
    Set wshLast = wbkLast.Worksheets(1)
    
    ' Neue Arbeitsmappe vorbereiten (etwaige Inhalte werden gelöscht!)
    wshNew.UsedRange.Delete
    wshNew.Range("A1").Value = "Kd-Nummer"
    wshNew.Range("B1").Value = "Betrag aktuell"
    wshNew.Range("C1").Value = "Betrag letzter"
    wshNew.Range("D1").Value = "Differenz"
    wshNew.Range("E1").Value = "Prozentual"
    
    wbkNew.Activate
    wshNew.Activate
    
    CopyData wshKd, wshNew, 1
    CopyData wshLast, wshNew, 2
    
    CloseOpenedWorkbooks colWorkbookOpened
    
    SortData wshNew
    
End Sub

Sub SortData(wshData As Worksheet)
    Dim rngData As Range
    With wshData.Sort
        With .SortFields
            .Clear
            Set rngData = wshData.Range(wshData.Range("A2"), wshData.Range("A2").End(xlDown))
            .Add Key:=rngData, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        End With
        .SetRange wshData.UsedRange
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Sub

Sub CopyData(wshSrc As Worksheet, wshDest As Worksheet, iColOffsetMoney As Integer)
    Dim rng As Range
    Dim lngTime As Long
    Dim rngDestKd As Range
    Set rng = wshSrc.Range("A2")
    Do
        Set rngDestKd = wshDest.Range("A:A").Find(what:=rng.Value, lookAt:=xlWhole)
        If rngDestKd Is Nothing Then
            ' neuen Eintrag anlegen
            If IsEmpty(wshDest.Range("A2")) Then
                Set rngDestKd = wshDest.Range("A2")
            Else
                Set rngDestKd = wshDest.Range("A1").End(xlDown).Offset(RowOffset:=1)
            End If
            With rngDestKd
                .Value = rng.Value
                .NumberFormat = rng.NumberFormat
                With .Offset(ColumnOffset:=3)
                    '.FormulaR1C1 = "=IF(AND(ISNUMBER(RC[-2]),ISNUMBER(RC[-1])),RC[-2]-RC[-1],"""")"
                    .FormulaR1C1 = "=RC[-2]-RC[-1]"
                    .NumberFormat = MONEYFORMAT
                End With
                With .Offset(ColumnOffset:=4)
                    .FormulaR1C1 = "=IF(ISNUMBER(RC[-1]),IF(RC[-3]=0,-1,RC[-1]/RC[-3]),"""")"
                    .NumberFormat = PERCENTFORMAT
                End With
            End With
        End If
        With rngDestKd.Offset(ColumnOffset:=iColOffsetMoney)
            .Value = rng.Offset(ColumnOffset:=1).Value
            .NumberFormat = MONEYFORMAT
        End With
        
        Set rng = rng.Offset(RowOffset:=1)
        ' Bei sehr langen Vorgängen Meldung "Application not Response" vermeiden...
        If Abs(lngTime - Timer) > 10 Then
            VBA.DoEvents
            lngTime = Timer
        End If
    Loop Until Intersect(wshSrc.UsedRange, rng) Is Nothing
    
End Sub

Function GetWorkbook(sFilename As String, col As Collection) As Workbook
    Dim wbk As Workbook
    Dim bFound As Boolean
    For Each wbk In Application.Workbooks
        If wbk.FullName = sFilename Then
            bFound = True
            Set GetWorkbook = wbk
            Exit For
        End If
    Next
    If Not bFound Then
        Set GetWorkbook = Application.Workbooks.Open(sFilename)
        col.Add GetWorkbook
    End If
End Function

Sub CloseOpenedWorkbooks(col As Collection)
    Dim wbk As Workbook
    Dim iPos As Integer
    For iPos = 1 To col.Count
        Set wbk = col.Item(iPos)
        wbk.Close False
    Next
End Sub

Function LastMonth() As String
    Dim dat As Date
    dat = DateSerial(Year(Date), Month(Date), 1)
    dat = DateAdd("m", -1, dat)
    LastMonth = Format(dat, "YYYY-MM")
End Function

LG, Ben