VBA - Performance - Leere Zeilen
15.11.2021 10:23:35
Nico
ich muss mich heute mal wieder mit einer Frage an euch wenden:
Ich habe in der Vergangenheit ein Makro gebaut, um eine große Excel auf monatlicher Basis in ein bestimmtes Format zu bringen und dann in verschiedene kleine Listen zu verteilen. Die Ausgangsliste kann dabei je nach Monat unterschiedlich viele Zeilen haben, jedoch stets den gleichen Aufbau.
Das erstellte Makro funktioniert inhaltlich auch einwandsfrei und nimmt die gewünschte Formatierung und Aufteilung vor.
Jedoch kopiert er bei jedem Blatt auch immer alle Leer-Zeilen (Also bis Zeile 1.048.576) mit, wodurch die Performance und die Speichergröße nicht hinnehmbar sind.
Eigentlich war der Plan, nur die Zeilen zu kopieren, wenn in Spalte A tatsächlich Werte oder Text stehen.
Hat hier jemand eine Idee, wo der Fehler liegt? Der Code hängt unten an.
Danke für eure Hilfe
Nico
Sub Formatierung_Test_Modul()
Dim Bereich As String
Dim Zelle As Range
Dim Tabelle As Worksheet
Dim Zeile As Long
Dim ZeileMax As Long
Dim rngFill As Range
Dim i As Long
Dim u As Long
Dim s As Integer
Dim r As Long
Dim pasteRowIndex As Long
Dim wksLast As Worksheet
'If ActiveWorkbook.Sheets.Count
Sub Header()
Dim WS_Count As Integer
Dim i As Integer
Dim r As Integer
Worksheets("Testblatt").Select
WS_Count = ActiveWorkbook.Worksheets.Count
For r = 3 To WS_Count
With ActiveWorkbook.Worksheets(r)
'.Rows("1:1").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
'.Range("B1").FormulaR1C1 = "=RIGHT(CELL(""dateiname"",RC[-1]),LEN(CELL(""dateiname"",RC[-1]))-FIND(""]"",CELL(""dateiname"",RC[-1])))"
'.Range("A:A").Replace _
'What:=Range("B1"), Replacement:="Buchung", _
'SearchOrder:=xlByColumns, MatchCase:=True
'.Rows("1:1").Delete Shift:=xlUp
Application.CutCopyMode = False
.Rows("1:12").Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove
.Range("A1").FormulaR1C1 = "LUCANET"
.Range("A3").FormulaR1C1 = "Name"
.Range("A4").FormulaR1C1 = "Buchungskreis"
.Range("A5").FormulaR1C1 = "Datenebene"
.Range("A6").FormulaR1C1 = "Bewertungsebene"
.Range("A8").FormulaR1C1 = "Spaltendefinition"
.Range("A11").FormulaR1C1 = "Buchungsdatum"
.Range("B8").FormulaR1C1 = "Konto"
.Range("C8").FormulaR1C1 = "Bewegungsart"
.Range("D8").FormulaR1C1 = "Soll"
.Range("E8").FormulaR1C1 = "Haben"
.Range("D11").FormulaR1C1 = "=Testblatt!RC"
.Range("E11").FormulaR1C1 = "=Testblatt!RC"
.Range("F8").FormulaR1C1 = "Text"
.Range("B1").FormulaR1C1 = "=RIGHT(CELL(""dateiname"",RC[-1]),LEN(CELL(""dateiname"",RC[-1]))-FIND(""]"",CELL(""dateiname"",RC[-1])))"
.Range("B5").FormulaR1C1 = "Ist"
.Range("B6").FormulaR1C1 = "IFRS 16 - Laufende Buchungen"
.Range("B3").FormulaR1C1 = "=CONCATENATE(""IFRS 16 - "",R[-2]C,"" "",R[8]C[3])"
.Range("B4").FormulaR1C1 = "=VLOOKUP(R[-3]C,Stammdaten!R1C1:R23C2,2,0)"
.Range("D1").FormulaR1C1 = "=SUM(R[12]C:R[999995]C)"
.Range("E1").FormulaR1C1 = "=SUM(R[12]C:R[999995]C)"
.Columns("A:Z").EntireColumn.AutoFit
.Range("D1").NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""?_);_(@_)"
.Range("E1").NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""?_);_(@_)"
.Range("D13:D999999").NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""?_);_(@_)"
.Range("E13:E999999").NumberFormat = "_(* #,##0.00_);_(* (#,##0.00);_(* ""-""?_);_(@_)"
.Range("G13:G" & Cells(Rows.Count, 2).End(xlUp).Row).Copy
.Range("A13:A" & Cells(Rows.Count, 2).End(xlUp).Row).PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
.Range("G:G").Delete Shift:=x1ToLeft
End With
Next r
End Sub
Sub WorksheetLoop()
Dim WS_Count As Integer
Dim i As Integer
Dim r As Integer
WS_Count = ActiveWorkbook.Worksheets.Count
For r = 3 To WS_Count
With ActiveWorkbook.Worksheets(r)
For i = .Cells(.Rows.Count, 1).End(xlUp).Row To 1 Step -1
If .Cells(i, 1) .Range("B1") Then .Rows(i).Delete
Next i
End With
Next r
End Sub