Hallo Ulrich,
kann ich alle Selects weglassen?
Vllt hast du Zeit und Lust mal über das Makro zu schauen und mir zu sagen was ich noch weglassen kann (Selects).
Sub Differenzprotokollbearbeiten()
Dim letzteZeile As Long
letzteZeile = Cells(Rows.Count, 2).End(xlUp).Row
'
' Differenzprotokollbearbeiten Makro
'
' 1. Zeile 1 mit Filter versehen
' 2. Alle Zeilen entfernen, wenn in Spalte AF eine 1 drinsteht
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
' 3. Spalte A markieren und eine Spalte hinzufügen und mit Überschrift Kennzahl versehen
Columns("A:A").Insert Shift:=xlToRight
Range("A1") = "Kennzahl"
' 4. Pivottabelle erstellen ("Zellenbeschriftungen = Filiale / Summe von VK diff ges.")
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
' 5. Aufsteigend sortieren in Spalte "Summe von VK diff ges."
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
' 6. In Spalte C zu jeder Filiale eine Kennzahl hinzufügen.
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
' 8. Aufsteigend sortieren in Spalte A ("Kennzahl")
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
' 10. Teilergebnisse in Spalten N (14) (VK diff ges.) und Z (26) (Diff nach Verbuchung) einfügen. Gruppieren nach: "Filiale" / Unter Verwendung von: "Summe"
Cells.Select
Application.CutCopyMode = False
Selection.Subtotal GroupBy:=6, Function:=xlSum, TotalList:=Array(14, 26), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
' 11. Gruppierungen entfernen
Selection.ClearOutline
' 12. Spalte G markieren und eine Spalte einfügen.
Columns("G:G").Insert Shift:=xlToRight
' 13. Mit der Formel Links nur die 8 Stelligen Filialnummern anzeigen lassen. Dann werden die Filialnummern kopiert und als Werte in Spalte F (6) eingefügt.
' Dies soll dazu dienen, das Wort "Ergebnis" in den Ergebniszeilen (Teilergebnis) zu entfernen.
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
' 14. Spalte G wieder entfernen
Columns("G:G").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
' 15. Nach Ergebniszeilen Filtern (in Spalte D (4) nach Leere Filtern)
' 16. Per Sverweis die Kennzahlen den Filialen in den Ergebniszeilen zuordnen.
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
' 19. Spalten N/V/Z als Währung formatieren
Range("N:N,V:V,Z:Z").Select
Range("Z1").Activate
Selection.NumberFormat = "#,##0.00 $"
' 20. Unnötige Spalten entfernen
Columns("AB:AG").Delete Shift:=xlToLeft
Range("A1").Select
End Sub
|