Thema Datum  Von Nutzer Rating
Antwort
Rot Großes Projekt mit Filtern/Sverweisen/Teilergebnis/Pivot
 20.02.2019 10:46:26 Emre
NotSolved

Ansicht des Beitrags:
Von:
Emre		 Datum:
20.02.2019 10:46:26		 Views:
1062		 Rating:
     
Antwort:
  Ja
Thema:
Großes Projekt mit Filtern/Sverweisen/Teilergebnis/Pivot

Hallo zusammen,

ich habe folgendes Makro aufgezeichnet, möchte es aber nicht nur auf diese Datei anwenden sondern jede Woche auf eine aktuelle mit anderen Werten.

Könnt ihr mal drüberschauen und es vereinfachen?

Erklärungen sind im Makro drin.

 

?
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
Sub Differenzprotokollbearbeiten()
'
' Differenzprotokollbearbeiten Makro
'
 
' 1. Zeile 1 mit Filter versehen
' 2. Alle Zeilen entfernen, wenn in Spalte AF eine 1 drinsteht
    ActiveSheet.Range("$A$1:$AF$124078").AutoFilter Field:=30, Criteria1:="1"
    Rows("78:78").Select
    Range("E78").Activate
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Delete Shift:=xlUp
    ActiveSheet.Range("$A$1:$AF$122264").AutoFilter Field:=30
' 3. Spalte A markieren und eine Spalte hinzufügen und mit Überschrift Kennzahl versehen
    Columns("A:A").Select
    Selection.Insert Shift:=xlToRight
    Range("A1").Select
    ActiveCell.FormulaR1C1 = "Kennzahl"
' 4. Pivottabelle erstellen ("Zellenbeschriftungen = Filiale / Summe von VK diff ges.")
    Cells.Select
    Sheets.Add
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:= _
        "Daten1!R1C1:R1048576C33", Version:=xlPivotTableVersion14).CreatePivotTable _
        TableDestination:="Tabelle1!R3C1", TableName:="PivotTable1", _
        DefaultVersion:=xlPivotTableVersion14
    Sheets("Tabelle1").Select
    Cells(3, 1).Select
    Range("B9").Select
    With ActiveSheet.PivotTables("PivotTable1")
        .InGridDropZones = True
        .RowAxisLayout xlTabularRow
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("Filiale")
        .Orientation = xlRowField
        .Position = 1
    End With
    With ActiveSheet.PivotTables("PivotTable1").PivotFields("VK diff ges.")
        .Orientation = xlRowField
        .Position = 2
    End With
    Range("A7").Select
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Filiale").Subtotals = Array _
        (False, False, False, False, False, False, False, False, False, False, False, False)
    Range("B9").Select
    ActiveSheet.PivotTables("PivotTable1").PivotFields("VK diff ges.").Subtotals = _
        Array(False, False, False, False, False, False, False, False, False, False, False, False)
    Range("B10").Select
    ActiveSheet.PivotTables("PivotTable1").AddDataField ActiveSheet.PivotTables( _
        "PivotTable1").PivotFields("VK diff ges."), "Anzahl von VK diff ges.", xlCount
    Range("B6").Select
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Anzahl von VK diff ges."). _
        Function = xlSum
    Range("B7").Select
' 5. Aufsteigend sortieren in Spalte "Summe von VK diff ges."
    ActiveSheet.PivotTables("PivotTable1").PivotFields("Filiale").AutoSort _
        xlAscending, "Summe von VK diff ges.", ActiveSheet.PivotTables("PivotTable1"). _
        PivotColumnAxis.PivotLines(1), 1
' 6. In Spalte C zu jeder Filiale eine Kennzahl hinzufügen.
    Range("C5").Select
    ActiveCell.FormulaR1C1 = "1"
    Range("C6").Select
    ActiveCell.FormulaR1C1 = "2"
    Range("C7").Select
    ActiveCell.FormulaR1C1 = "3"
    Range("C5:C7").Select
    Selection.AutoFill Destination:=Range("C5:C1987")
    Range("C5:C1987").Select
    Range("D8").Select
' 7. Per Sverweis im Tabellenblatt "Daten1" die Kennzahlen der Filialen zuordnen
    Sheets("Daten1").Select
    Range("A2").Select
    ActiveCell.FormulaR1C1 = "=+VLOOKUP(RC[5],Tabelle1!C:C[2],3,FALSE)"
    Range("A2").Select
    Selection.AutoFill Destination:=Range("A2:A122264")
    Range("A2:A122264").Select
    Rows("1:1").Select
' 8. Aufsteigend sortieren in Spalte A ("Kennzahl")
    Selection.AutoFilter
    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
' 9. Formeln durch Werte ersetzen
    Range("A2").Select
    Range(Selection, Selection.End(xlDown)).Select
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
        :=False, Transpose:=False
' 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
    Range("J9").Select
    ActiveWindow.SmallScroll Down:=-24
' 12. Spalte G markieren und eine Spalte einfügen.
    Columns("G:G").Select
    Selection.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").Select
    Selection.AutoFill Destination:=Range("G2:G124244")
    Range("G2:G124244").Select
    Selection.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)
    Range("F3").Select
    ActiveSheet.Range("$A$1:$AG$124244").AutoFilter Field:=4, Criteria1:="="
' 16. Per Sverweis die Kennzahlen den Filialen in den Ergebniszeilen zuordnen.
    Range("A78").Select
    ActiveCell.FormulaR1C1 = "=+VLOOKUP(RC[5],Tabelle1!C:C[2],3,FALSE)"
    Range("A78").Select
    Selection.Copy
    Range("A115:A124245").Select
    ActiveSheet.Paste
    Range("F1951").Select
    Range(Selection, Selection.End(xlDown)).Select
' 17. In der letzten Ergebniszeile stand noch das Wort Ergebnis nach der Filialnummer.Ich versteh zwar nicht warum aber das muss entfernt werden.
'     Damit der Sverweis greift musste die Zelle als Text formatiert werden.
    Range("F124245").Select
    Application.CutCopyMode = False
    ActiveCell.FormulaR1C1 = "31309095"
    Range("F124245").Select
    Selection.NumberFormat = "@"
    ActiveCell.FormulaR1C1 = "31309095"
    Range("N124245").Select
    ActiveWindow.SmallScroll Down:=-18
    Range("F121370").Select
    Range(Selection, Selection.End(xlUp)).Select
' 18. Alle Ergebniszeilen bis Spalte AE (31) in "Knallrot" / Schriftfarbe "Weiss" und "Fett" formatiert.
    Range("D230").Select
    ActiveWindow.SmallScroll Down:=-33
    Range("A59:AE32831").Select
    ActiveWindow.SmallScroll Down:=-87
    Range(Selection, Selection.End(xlDown)).Select
    ActiveWindow.SmallScroll Down:=24
    With Selection.Interior
        .Pattern = xlSolid
        .PatternColorIndex = xlAutomatic
        .ThemeColor = xlThemeColorAccent2
        .TintAndShade = -0.249977111117893
        .PatternTintAndShade = 0
    End With
    With Selection.Font
        .ThemeColor = xlThemeColorDark1
        .TintAndShade = 0
    End With
    ActiveWindow.SmallScroll Down:=-18
    Selection.Font.Bold = True
    Selection.Font.Bold = False
    Selection.Font.Bold = True
    ActiveSheet.Range("$A$1:$AG$124244").AutoFilter Field:=4
    Range("L10").Select
    ActiveWindow.SmallScroll Down:=-39
' 19. Spalten N/V/Z als Währung formatieren
    Range("N:N,V:V,Z:Z").Select
    Range("Z1").Activate
    Selection.NumberFormat = "#,##0.00 $"
    Range("S10").Select
' 20. Unnötige Spalten entfernen
    Columns("AB:AG").Select
    Selection.Delete Shift:=xlToLeft
    Range("AA1").Select
End Sub

Vielen Dank im Voraus

 

Grüße Emre

Ihre Antwort
  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen
Thema: Name: Email:
WYSIWYG-Editor, ctl00_Content_editor1



  • Bitte beschreiben Sie Ihr Problem möglichst ausführlich. (Wichtige Info z.B.: Office Version, Betriebssystem, Wo genau kommen Sie nicht weiter)
  • Bitte helfen Sie ebenfalls wenn Ihnen geholfen werden konnte und markieren Sie Ihre Anfrage als erledigt (Klick auf Häckchen)
  • Bei Crossposting, entsprechende Links auf andere Forenbeiträge beifügen / nachtragen
  • Codeschnipsel am besten über den Code-Button im Text-Editor einfügen
  • Die Angabe der Emailadresse ist freiwillig und wird nur verwendet, um Sie bei Antworten auf Ihren Beitrag zu benachrichtigen

Thema Datum  Von Nutzer Rating
Antwort
Rot Großes Projekt mit Filtern/Sverweisen/Teilergebnis/Pivot
 20.02.2019 10:46:26 Emre
NotSolved