AW: langsamen VBA code mit Array beschleunigen
14.02.2025 15:03:57
Tobi_84
Hallo Piet, Hallo Yal,
@Piet: Sorry, das hat leider nicht geklappt.
Bitte entschuldigt, ich hätte mehr Informationen teilen sollen.
Ich habe einen Excel Export aus einem Programm und möchte diesen Export weiter verarbeiten.
Dafür benötige ich aber die ausgelesenen Daten an entsprechender Stelle.
Das Problem welches ich habe ist, das mein VBA Code zu groß und zu langsam ist :(.
Wichtig ist die Stelle mit den Datenpaaren ("1 Pärchen = 2 durch Zeilenumbruch getrennte Daten").
Im Tabellenblatt EPLSheet sind Zellen mit beliebig langen Daten getrennt durch Zeilenumbrüche.
Jede einzelne von diesen Zellen soll nach dem Zeilenumbruch getrennt werden und die dadurch entstehenden Daten
benötige ich abwechselnd über 2 Spalten untereinander verteilt.
Ich habe den Code etwas aufbereitet, hoffe es hilft.
Sub export_Label()
'
' export_Label Makro
'
Dim EinzelneWorte() As String, Text As String
Dim i As Integer, lastRow As Integer, intRow As Integer, intLastRow As Integer
Dim cell As Range
' Bildschirmaktualisierung & Mitteilungen aus
Application.ScreenUpdating = False
Application.DisplayAlerts = False
With Worksheets("Druck")
'Tabellenblatt leeren und als Text formatieren
.Range(Cells(3, 1), Cells(1000, 26)).Clear
.Range(Cells(3, 1), Cells(1000, 26)).NumberFormat = "@"
.Cells(1, 5).Interior.ColorIndex = xlNone
' #1 (Reihe 10 - 50)
' 1. Zelle aus Programmexport übertragen
.Cells(10, 1).Value = Worksheets("EplSheet").Cells(2, 5).Value
'---------------------------------------------------------------------------------------------
' Lässt sich hier etwas optimieren?
' Wichtig ist, dass die Pärchen abwechselend über Spalte B und C verteilt werden.
' 2. Zelle aus Programmexport übertragen
Text = Worksheets("EplSheet").Cells(2, 6).Value
' Zeichenkette trennen & in ein Tabellenblatt eintragen
'Teil 1 von Pärchen #1 in Spalte -B- einfügen: Zelle (10, 2)
EinzelneWorte = Split(Text, Chr(10))
For i = 0 To UBound(EinzelneWorte)
.Cells(10, i + 2) = EinzelneWorte(i)
Next i
'Teil 2 von Pärchen #1 in Spalte -B- einfügen: Zelle (10, 3)
.Cells(10, 3).Cut Cells(11, 2)
'Pärchen #2 in Spalte -C- einfügen: Zelle (10, 4) & (10, 5)
.Cells(10, 4).Cut Cells(10, 3)
.Cells(10, 5).Cut Cells(11, 3)
'Pärchen #3 in Spalte -B- einfügen: Zelle (10, 6) & (10, 7)
.Cells(10, 6).Cut Cells(12, 2)
.Cells(10, 7).Cut Cells(13, 2)
'Pärchen #4 in Spalte -C- einfügen: Zelle (10, 8) & (10, 9)
.Cells(10, 8).Cut Cells(12, 3)
.Cells(10, 9).Cut Cells(13, 3)
'Pärchen #5 in Spalte -B- einfügen: Zelle (10, 10) & (10, 11)
.Cells(10, 10).Cut Cells(14, 2)
.Cells(10, 11).Cut Cells(15, 2)
'Pärchen #6 in Spalte -C- einfügen: Zelle (10, 12) & (10, 13)
.Cells(10, 12).Cut Cells(14, 3)
.Cells(10, 13).Cut Cells(15, 3)
'---------------------------------------------------------------------------------------------
' 3. Zelle aus Programmexport übertragen
.Cells(19, 4).Value = Worksheets("EplSheet").Cells(2, 7).Value
' 4. Zelle aus Programmexport übertragen
Text = Worksheets("EplSheet").Cells(2, 8).Value
' Zeichenkette trennen & in ein Tabellenblatt eintragen
For i = 0 To UBound(EinzelneWorte)
EinzelneWorte = Split(Text, ";;;")
Cells(21, 4).Resize(UBound(EinzelneWorte) + 1) = Application.Transpose(EinzelneWorte)
Next i
' #2 (Reihe 60 - 100)
' 1. Zelle aus Programmexport übertragen
.Cells(60, 1).Value = Worksheets("EplSheet").Cells(3, 5).Value
' 2. Zelle aus Programmexport übertragen
Text = Worksheets("EplSheet").Cells(3, 6).Value
' Zeichenkette trennen & in ein Tabellenblatt eintragen
'Teil 1 von Pärchen #1 in Spalte -B- einfügen: Zelle (60, 2)
EinzelneWorte = Split(Text, Chr(10))
For i = 0 To UBound(EinzelneWorte)
.Cells(60, i + 2) = EinzelneWorte(i)
Next i
'Teil 2 von Pärchen #1 in Spalte -B- einfügen: Zelle (60, 3)
.Cells(60, 3).Cut Cells(61, 2)
'Pärchen #2 in Spalte -C- einfügen: Zelle (60, 4) & (60, 5)
.Cells(60, 4).Cut Cells(60, 3)
.Cells(60, 5).Cut Cells(61, 3)
'Pärchen #3 in Spalte -B- einfügen: Zelle (60, 6) & (60, 7)
.Cells(60, 6).Cut Cells(62, 2)
.Cells(60, 7).Cut Cells(63, 2)
'Pärchen #4 in Spalte -C- einfügen: Zelle (60, 8) & (60, 9)
.Cells(60, 8).Cut Cells(62, 3)
.Cells(10, 9).Cut Cells(63, 3)
'Pärchen #5 in Spalte -B- einfügen: Zelle (60, 10) & (60, 11)
.Cells(60, 10).Cut Cells(64, 2)
.Cells(60, 11).Cut Cells(65, 2)
'Pärchen #6 in Spalte -C- einfügen: Zelle (60, 12) & (60, 13)
.Cells(60, 12).Cut Cells(64, 3)
.Cells(60, 13).Cut Cells(65, 3)
' 3. Zelle aus Programmexport übertragen
.Cells(69, 4).Value = Worksheets("EplSheet").Cells(3, 7).Value
' 4. Zelle aus Programmexport übertragen
Text = Worksheets("EplSheet").Cells(3, 8).Value
' Zeichenkette trennen & in ein Tabellenblatt eintragen
For i = 0 To UBound(EinzelneWorte)
EinzelneWorte = Split(Text, ";;;")
Cells(71, 4).Resize(UBound(EinzelneWorte) + 1) = Application.Transpose(EinzelneWorte)
Next i
'---------------------------------------------------------------------------------------------
' #3 (Reihe 110 - 150)
' x beliebige Wierderholung in 50er Reihenschritten
'---------------------------------------------------------------------------------------------
' max. Zeichen zählen und Schrift rot färben Dim ws As Worksheet
Set ws = ThisWorkbook.Sheets("Druck")
lastRow = ws.Cells(ws.Rows.Count, "D").End(xlUp).Row
For Each cell In ws.Range("D3:N" & lastRow)
If Len(cell.Value) > 25 Then
cell.Font.Color = RGB(255, 0, 0)
Else
cell.Interior.ColorIndex = xlNone
End If
Next cell
' leere Zellen löschen
intLastRow = Cells.SpecialCells(xlCellTypeLastCell).Row
For intRow = intLastRow To 1 Step -1
If Application.CountA(Rows(intRow)) = 0 Then
Rows(intRow).Delete
End If
Next intRow
' Auswertung ob alle Werte erfasst wurden
If Not WorksheetFunction.CountA(Sheets("EplSheet").Range("E2:E200")) = WorksheetFunction.CountA(Sheets("Druck").Range("A2:A200")) Then
.Cells(1, 5).Interior.ColorIndex = 3
Else
.Cells(1, 5).Interior.ColorIndex = 4
End If
' Zelle (Offset 1) mit Leerzeichen am Ende einfügen
.Range("D" & Rows.Count).End(xlUp).Offset(1, 0).Value = " "
End With
' Bildschirmaktualisierung & Mitteilungen aus
Application.DisplayAlerts = True
Application.ScreenUpdating = True
End Sub