Dateigröße steigend nach Ausführung Makro
29.07.2016 10:35:15
Michael
ich habe eine Excel-Datei mit etwa 500 kB angelegt. Es handelt sich um eine Tabelle mit vielen Spezifikationen zu einem Fahrzeug. Ausgehend davon werden mehrere Pivot-Tabellen auf zwei Arbeitsblätter erstellt. Diese enthalten die gleichen Informationen und dienen lediglich für eine andere, etwas benutzerfreundlichere Darstellung als Matrix.
Um den Schreibaufwand zu erleichtern, habe ich eine Aktualisierung per Makro programmiert. Es werden Zeilen hinzugefügt, wenn Daten der Ursprungstabelle hinzugefügt werden, werden die Pivot-Tabellen aktualisiert und anschließend werden leere Zeilen gelöscht. Zusätzlich werden darauffolgend Formatierungen vorgenommen.
Nun zum eigentlichen Problem:
Ohne wirklich Daten in der Ursprungstabelle hinzuzufügen, das heißt es wird nur der Button zum Ausführen des Makros gedrückt, steigt die Dateigröße immens an (nach nur wenigen Durchläufen auf bis zu 3 MB; pro Klick etwa exponentiell um 20-30 kB). Außerdem dauert die Ausführung des Makros relativ lange (knapp 10 Sekunden).
Woran kann es liegen, dass die Dateigröße ansteigt, obwohl keine neuen Daten hinzugefügt werden?
Gibt es einen internen Cache, den man leeren kann?
Gibt es die Möglichkeit die Daten in eine neue Datei zu überführen (nicht die Copy&Paste-Variante von Speichern unter)?
Im Grunde soll die Dateigröße verhältnismäßig konstant bleiben und nicht auf mehrere MB anwachsen.
Ich selbst habe wenig Erfahrung mit VBA Makro Programmierung und habe mir das meiste selbst beigebracht bzw. als Informationen gesammelt.
Tipps in Richtung Prüfung des verwendeten Datenbereichs, Löschen von Leerzeilen, Exportieren und Entfernen/Importieren von Makros und Überprüfen der Zellen auf Formatierungen habe ich bereits getestet. Dabei hat sich die Dateigröße nur geringfügig reduziert.
Hier das programmierte Makro:
Sub Test()
Dim last As Long 'letzte Zeile
Dim i As Long 'Zeile
Dim k As Long
Dim lastcell As Long
'Variablendeklarationen
last = Range("B1000").End(xlUp).Row
'letzte belegte Zelle
i = 19
k = 19
'Anzahl Zeilen in Ursprungstabelle
'Unruhiger Bildschirm
Application.ScreenUpdating = False
'Löschen Schattentabelle
Sheets("Pivot Schattentabelle").Select
Columns("C:D").Delete
Sheets("Pivot Tabelle").Select
Range("E19:XFD1000").Delete
Cells.FormatConditions.Delete
'Zellen einfügen! Wichtig: letzte beschriebene Zelle muss neu ermittelt werden!
Do Until i = last
'Code wiederholt ausführen bis i größer als last ist
If Cells(i, 3).Value "" Then
'Code ausführen wenn Zelle einen Wert hat
i = i + 1
'Zeile um 1 erhöhen
last = Range("B1000").End(xlUp).Row
Else
'Wenn Bedingung nicht erfüllt ist, dann ...
Range(Rows(i + 1), Rows(i + 10)).Insert Shift:=xlDown
'unter der Zelle 10 Zeilen einfügen
i = i + 11
'Zeile um 11 erhöhen um Endlosschleife zu vermeiden
last = Range("B1000").End(xlUp).Row
End If
Loop
'SchattenPivot
Call SchattenPivotHinzufügen
'Aktualisieren der Pivot-Matrix
Dim wS As Worksheet
Dim pt As PivotTable
For Each wS In ActiveWorkbook.Worksheets
For Each pt In wS.PivotTables
pt.RefreshTable
Next pt
Next wS
'SchattenPivot
Call SchattenPivotZellenLöschen
'SchattenPivot
Call SchattenPivotXeinfügen
Sheets("Pivot Tabelle").Select
'Dynamisches Löschen von leeren Zellen
For a = ActiveSheet.Cells(2000, 2).End(xlUp).Row To 19 Step -1
If ActiveSheet.Cells(a, 2).Value = "" And ActiveSheet.Cells(a - 1, 2).Value = "" Then
Rows(a).Delete Shift:=xlUp
End If
Next a
'Spaltenbreite von A, B, C, D
Columns("A:A").Select
Selection.ColumnWidth = 0
Columns("B:B").Select
Selection.ColumnWidth = 35
Columns("C:C").Select
Selection.ColumnWidth = 35
Columns("D:D").Select
Selection.ColumnWidth = 21
'Text im Kopf immer linksbündig
'noch dynamisch machen, wenn rdyn dazukommt !!
'lastcell = Cells(17, 256).End(xlToLeft).Select
Range("D4", "GJ17").Select
With Selection
.HorizontalAlignment = xlLeft
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
'X in Pivot-Matrix einfügen
Call PivotXeinfügen
'Formatierung der Ansicht
Call Formatierung
'Sprung in B1
Range("B1").Select
'Zwischenspeicher löschen
ClearClipboard = True
'Unruhiger Bildschirm
Application.ScreenUpdating = True
End Sub
Sub SchattenPivotHinzufügen()
Sheets("Pivot Schattentabelle").Select
Dim lastrow As Long
Dim x As Long
Dim y As Long
'letzte belegte Zelle
lastrow = Range("B1000").End(xlUp).Row
'Startzeile
x = 3
y = 3
'Zellen einfügen
Do Until x = lastrow
'Code wiederholt ausführen bis i größer als last ist
If Cells(x, 2).Value "" Then
'Code ausführen wenn Zelle einen Wert hat
x = x + 1
'Zeile um 1 erhöhen
lastrow = Range("B1000").End(xlUp).Row
Else
'Wenn Bedingung nicht erfüllt ist, dann ...
Range(Rows(x + 1), Rows(x + 10)).Insert Shift:=xlDown
'unter der Zelle 15 Zeilen einfügen
x = x + 11
lastrow = Range("B1000").End(xlUp).Row
End If
Loop
End Sub
Sub SchattenPivotXeinfügen()
Sheets("Pivot Schattentabelle").Select
Dim spalte As Long
Dim zeile As Long
Dim last As Long
spalte = 3
zeile = 3
last = Range("B1000").End(xlUp).Row
Do Until zeile = last + 1
If Cells(zeile, 1).Value "" Then
Cells(zeile, spalte).FormulaR1C1 = "=RC[-2]&RC[-1]"
zeile = zeile + 1
last = Range("B1000").End(xlUp).Row
Else
zeile = zeile + 1
last = Range("B1000").End(xlUp).Row
End If
Loop
End Sub
Sub SchattenPivotZellenLöschen()
Sheets("Pivot Schattentabelle").Select
Dim last As Long
last = Range("B1000").End(xlUp).Row
'Dynamisches Löschen von leeren Zellen --> eine muss übrig bleiben
Dim lngSpalteSchatten As Long
'** Spalte, die auf Leerzeichen geprüft werden soll
lngSpalteSchatten = 1
For b = ActiveSheet.Cells(1000, lngSpalteSchatten).End(xlUp).Row To 3 Step -1
If ActiveSheet.Cells(b, 1).Value = "" And ActiveSheet.Cells(b - 1, 2).Value = "" Then
Rows(b).Delete Shift:=xlUp
End If
Next b
End Sub
Sub PivotXeinfügen()
Dim lastrow As Long
Dim lastcolumn As Long
Dim spalte As Long
Dim zeile As Long
Sheets("Pivot Tabelle").Select
lastrow = Range("B1000").End(xlUp).Row
lastcolumn = Cells(17, 256).End(xlToLeft).Column
For spalte = 5 To lastcolumn Step 1
For zeile = 19 To lastrow Step 1
Cells(zeile, spalte).FormulaR1C1 = "=IF(ISNA(VLOOKUP(R18C&RC2,'Pivot _
Schattentabelle'!R3C3:R500C3,2,FALSE)),"""",""l"")"
Next
Next
End Sub
Sub Formatierung()
Dim firstcellmatrix As Long
Dim lastcellmatrix As Long
Dim lastrow As Long
lastrow = Range("B2500").End(xlUp).Row
lastcellmatrix = Cells(lastrow, 256).End(xlToLeft).Select
Range(Selection, "E19").Select
With Selection.Font
.Name = "Wingdings"
.Size = 10
.Strikethrough = False
.Superscript = False
.Subscript = False
.OutlineFont = False
.Shadow = False
.Underline = xlUnderlineStyleNone
.ColorIndex = xlAutomatic
.TintAndShade = 0
.ThemeFont = xlThemeFontNone
End With
With Selection
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.WrapText = False
.Orientation = 0
.AddIndent = False
.IndentLevel = 0
.ShrinkToFit = False
.ReadingOrder = xlContext
.MergeCells = False
End With
Selection.Borders(xlDiagonalDown).LineStyle = xlNone
Selection.Borders(xlDiagonalUp).LineStyle = xlNone
With Selection.Borders(xlEdgeLeft)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeTop)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeBottom)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlEdgeRight)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideVertical)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.Borders(xlInsideHorizontal)
.LineStyle = xlContinuous
.ColorIndex = 0
.TintAndShade = 0
.Weight = xlThin
End With
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=$B19="""""
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).Borders(xlLeft).LineStyle = xlNone
Selection.FormatConditions(1).Borders(xlRight).LineStyle = xlNone
Selection.FormatConditions(1).Borders(xlBottom).LineStyle = xlNone
With Selection.FormatConditions(1).Borders(xlTop)
.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With
Selection.FormatConditions(1).StopIfTrue = False
Selection.FormatConditions.Add Type:=xlExpression, Formula1:="=FINDEN(""S"";$B19)=1"
Selection.FormatConditions(Selection.FormatConditions.Count).SetFirstPriority
Selection.FormatConditions(1).Borders(xlLeft).LineStyle = xlNone
Selection.FormatConditions(1).Borders(xlRight).LineStyle = xlNone
Selection.FormatConditions(1).Borders(xlTop).LineStyle = xlNone
With Selection.FormatConditions(1).Borders(xlBottom)
.LineStyle = xlContinuous
.TintAndShade = 0
.Weight = xlThin
End With
With Selection.FormatConditions(1).Interior
.PatternColorIndex = xlAutomatic
.ThemeColor = xlThemeColorDark2
.TintAndShade = 0
End With
Selection.FormatConditions(1).StopIfTrue = False
End Sub
Die zugehörige Excel-Datei kann ich aus Geheimhaltungsgründen nicht beifügen.
Ich hoffe Ihr könnt mir dabei weiterhelfen!
Vielen Dank!
Anzeige