Sub Differenzprotokollbearbeiten()
Dim letzteZeile As Long
letzteZeile = Cells(Rows.Count, 2).End(xlUp).Row
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With ActiveSheet
.Range("A1").AutoFilter Field:=30, Criteria1:="1"
.Rows(1).Hidden = True
.UsedRange.SpecialCells(xlCellTypeVisible).Delete
.Rows(1).Hidden = False
.AutoFilterMode = False
End With
Application.DisplayAlerts = True
Application.ScreenUpdating = True
Columns("A:A").Insert Shift:=xlToRight
Range("A1") = "Kennzahl"
Cells.Select
Sheets.Add
ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
"Daten1!A1:AE" & letzteZeile, Version:=xlPivotTableVersion14).CreatePivotTable _
TableDestination:="Tabelle1!R3C1", TableName:="PivotTable", _
DefaultVersion:=xlPivotTableVersion14
Sheets("Tabelle1").Select
With ActiveSheet.PivotTables("PivotTable").PivotFields("Filiale")
.Orientation = xlRowField
.Position = 1
End With
ActiveSheet.PivotTables("PivotTable").AddDataField ActiveSheet.PivotTables( _
"PivotTable").PivotFields("VK diff ges."), "Summe von VK diff ges.", xlSum
ActiveCell.Columns("A:B").EntireColumn.Select
Selection.Copy
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
ActiveCell.Rows("1:2").EntireRow.Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlUp
ActiveCell.Rows("1:1").EntireRow.Select
Selection.AutoFilter
ActiveCell.Offset(4, 1).Range("A1").Select
ActiveWorkbook.Worksheets("Tabelle1").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Tabelle1").AutoFilter.Sort.SortFields.Add Key:= _
ActiveCell.Offset(-1, 0).Range("A1"), SortOn:=xlSortOnValues, Order:= _
xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Tabelle1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Worksheets("Tabelle1").Rows(2).Delete
Dim Ende As Long
With ActiveSheet
.Range("C2") = "1"
.Range("C3") = "2"
Ende = Cells(Rows.Count, 2).End(xlUp).Row
.Range("C2:C3").AutoFill Destination:=Range("C2:C" & Ende), Type:=xlFillDefault
End With
Sheets("Daten1").Select
Dim z As Long
Dim lz As Long
Dim s As Integer
lz = Cells(Rows.Count, 2).End(xlUp).Row
If Cells(Rows.Count, 2) <> "" Then lz = Rows.Count
On Error Resume Next
For z = 2 To lz
For s = 3 To 3
Cells(z, 1).Value = WorksheetFunction.VLookup(Cells(z, 6).Value, Range("Tabelle1!A:C"), s, False)
If Err.Number > 0 Then
Cells(z, 1).Value = 0
Err.Clear
End If
Next s
Next z
Selection.AutoFilter
ActiveWorkbook.Worksheets("Daten1").AutoFilter.Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Daten1").AutoFilter.Sort.SortFields.Add Key:=Range _
("A1"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _
xlSortNormal
With ActiveWorkbook.Worksheets("Daten1").AutoFilter.Sort
.Header = xlYes
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Cells.Select
Application.CutCopyMode = False
Selection.Subtotal GroupBy:=6, Function:=xlSum, TotalList:=Array(14, 26), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
Selection.ClearOutline
Columns("G:G").Insert Shift:=xlToRight
Range("G2").Select
ActiveCell.FormulaR1C1 = "=+LEFT(RC[-1],8)"
Range("G2").AutoFill Destination:=Range("G2:G" & letzteZeile)
Range("G2:G" & letzteZeile).Copy
Range("F2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
Columns("G:G").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
lz = Cells(Rows.Count, 2).End(xlUp).Row
If Cells(Rows.Count, 2) <> "" Then lz = Rows.Count
On Error Resume Next
For z = 2 To lz
For s = 3 To 3
Cells(z, 1).Value = WorksheetFunction.VLookup(Cells(z, 6).Value, Range("Tabelle1!A:C"), s, False)
If Err.Number > 0 Then
Cells(z, 1).Value = 0
Err.Clear
End If
Next s
Next z
Range("N:N,V:V,Z:Z").Select
Range("Z1").Activate
Selection.NumberFormat = "#,##0.00 $"
Columns("AB:AG").Delete Shift:=xlToLeft
Range("A1").Select
End Sub