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
|