Option Explicit
Sub AnalyzeAndCopy()
Dim wsh As Worksheet
Dim rngChk As Range
Dim rngData As Range
Dim wshNew As Worksheet
Set wsh = ThisWorkbook.Worksheets(1)
Set rngData = wsh.Range(wsh.Range("H3"), wsh.Cells(wsh.UsedRange.Count + wsh.UsedRange.Top, 24))
For Each rngChk In rngData.Cells
If Not rngChk.Value = "" Then
If wshNew Is Nothing Then
Set wshNew = CreateNewWorkbook
End If
AddNewValue wshNew, rngChk
End If
Next
End Sub
Function CreateNewWorkbook() As Worksheet
Dim wbk As Workbook
Dim wsh As Worksheet
Set wbk = Application.Workbooks.Add()
Set wsh = wbk.Worksheets(1)
wsh.Range("A1").Value = "kreditor"
wsh.Range("B1").Value = "kunde"
wsh.Range("C1").Value = "Rg-Nr."
With wsh.Range("D:D")
.Cells(1, 1).Value = "datum"
.NumberFormat = "m/d/yyyy"
End With
With wsh.Range("E:E")
.Cells(1, 1).Value = "betrag"
.NumberFormat = "_-* #,##0.00 [$€-407]_-;-* #,##0.00 [$€-407]_-;_-* ""-""?? [$€-407]_-;_-@_-"
End With
wsh.Range("F1").Value = "kostenstelle"
wsh.Range("G1").Value = "gegenkonto"
With wsh.Range("H:H")
.Cells(1, 1).Value = "brutto"
.NumberFormat = "_-* #,##0.00 [$€-407]_-;-* #,##0.00 [$€-407]_-;_-* ""-""?? [$€-407]_-;_-@_-"
End With
Set CreateNewWorkbook = wsh
End Function
Sub AddNewValue(wshOutSheet As Worksheet, rngMoney As Range)
Dim rngWrite As Range
Dim rngKreditor As Range
Set rngWrite = wshOutSheet.Cells(wshOutSheet.UsedRange.Rows.Count + 1, 1)
Set rngKreditor = rngMoney.Worksheet.Cells(rngMoney.Row, 4)
rngWrite.Value = rngKreditor.Value
rngWrite.Offset(ColumnOffset:=1).Value = rngKreditor.Offset(ColumnOffset:=1).Value
rngWrite.Offset(ColumnOffset:=2).Value = rngKreditor.Offset(ColumnOffset:=2).Value
rngWrite.Offset(ColumnOffset:=3).Value = rngKreditor.Offset(ColumnOffset:=3).Value
rngWrite.Offset(ColumnOffset:=4).Value = rngMoney.Value
rngWrite.Offset(ColumnOffset:=5).Value = rngMoney.EntireColumn.Cells(1, 1).Value
rngWrite.Offset(ColumnOffset:=6).Value = rngMoney.EntireColumn.Cells(2, 1).Value
rngWrite.Offset(ColumnOffset:=7).FormulaR1C1 = "=IF(RC[-1]=3300,RC[-3]*1.07,RC[-3]*1.19)"
End Sub