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
Set wbkNew = ThisWorkbook
Set wshNew = wbkNew.Worksheets(1)
Set wbkKd = GetWorkbook(ThisWorkbook.Path & "\Kunden.xlsx", colWorkbookOpened)
Set wshKd = wbkKd.Worksheets(1)
Set wbkLast = GetWorkbook(ThisWorkbook.Path & "\Abgleich - " & LastMonth & ".xlsx", colWorkbookOpened)
Set wshLast = wbkLast.Worksheets(1)
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
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 = "=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)
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