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.Cells(3, 7), wsh.Cells(wsh.UsedRange.Count + wsh.UsedRange.Top, 20))
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 = "Lieferant"
With wsh.Range("C:C")
.Cells(1, 1).Value = "Datum"
.NumberFormat = "d/m"
End With
With wsh.Range("D:D")
.Cells(1, 1).Value = "Netto"
.NumberFormat = "_-* #,##0.00 [$€-407]_-;-* #,##0.00 [$€-407]_-;_-* ""-""?? [$€-407]_-;_-@_-"
End With
wsh.Range("E1").Value = "Kostenstelle"
wsh.Range("F1").Value = "Gegenkonto"
wsh.Range("G1").Value = "Rg-Nr"
Set CreateNewWorkbook = wsh
End Function
Sub AddNewValue(wshOutSheet As Worksheet, rngMoney As Range)
Dim rngWrite As Range
Dim rngKreditor As Range
Set rngWrite = Intersect(wshOutSheet.Range("A:A"), wshOutSheet.UsedRange).Offset(rowOffset:=1)
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:=3).Value
rngWrite.Offset(ColumnOffset:=3).Value = rngMoney.Value
rngWrite.Offset(ColumnOffset:=4).Value = rngMoney.EntireColumn.Cells(1, 1).Value
rngWrite.Offset(ColumnOffset:=5).Value = rngMoney.EntireColumn.Cells(2, 1).Value
End Sub