AW: Salden aufteilen in Blätter
28.03.2017 15:44:48
UweD
Hallo Helmut
hier mal ein Makro.
in ein Normales Modul
Sub Sortieren()
Dim LR As Long, ZZ, Anz As Integer
Application.ScreenUpdating = False
With Sheets("Rohdaten")
If .AutoFilterMode Then .AutoFilterMode = False ' Autofilter ausschalten
LR = .Cells(.Rows.Count, "H").End(xlUp).Row 'letzte Zeile der Spalte
.Range("J1") = "TEMP"
.Range("J2").FormulaArray = _
"=IF(RC[-2]=""S A L D O"",INDEX(R[1]C[-2]:R" & LR & "C[-2],MATCH(TRUE,IF(R[1]C[-2]:R" _
& LR & "C[-2]<>"""",TRUE),0)),"""")"
.Range("J2").Copy .Range("J3:J" & LR)
With .Range("J2:J" & LR)
.Value = .Value
.NumberFormat = "0.00"
End With
.Columns("J:J").EntireColumn.AutoFit
'Positive
Set ZZ = Sheets("Positive")
ZZ.Cells.ClearContents
.Range("J1:J" & LR).AutoFilter Field:=1, Criteria1:=">0"
Anz = WorksheetFunction.CountIf(.Range("J2:J" & LR), ">0")
If Anz > 0 Then
.Rows("2:" & LR).Copy ZZ.Rows(1)
ZZ.Columns("D:D").Replace What:="Datum", Replacement:="Valuta", LookAt:=xlWhole
ZZ.Cells.Font.Bold = False
End If
.AutoFilterMode = False
'Negative
Set ZZ = Sheets("Negative")
ZZ.Cells.ClearContents
.Range("J1:J" & LR).AutoFilter Field:=1, Criteria1:="<0"
Anz = WorksheetFunction.CountIf(.Range("J2:J" & LR), "<0")
If Anz > 0 Then
.Rows("2:" & LR).Copy ZZ.Rows(1)
ZZ.Columns("D:D").Replace What:="Datum", Replacement:="Valuta", LookAt:=xlWhole
ZZ.Cells.Font.Bold = False
End If
.AutoFilterMode = False
'Null
Set ZZ = Sheets("Null")
ZZ.Cells.ClearContents
.Range("J1:J" & LR).AutoFilter Field:=1, Criteria1:="0,00"
Anz = WorksheetFunction.CountIf(.Range("J2:J" & LR), "=0")
If Anz > 0 Then
.Rows("2:" & LR).Copy ZZ.Rows(1)
ZZ.Columns("D:D").Replace What:="Datum", Replacement:="Valuta", LookAt:=xlWhole
ZZ.Cells.Font.Bold = False
End If
.AutoFilterMode = False
.Columns("J:J").ClearContents
End With
End Sub
LG UweD