VBA Makro läuft sehr lange, kann hier optimiert werden?

Question

Hallo,

ich habe ein Makro am Laufen, welches mir 21 Zellen pro Zeile vollgepackt mit Formeln bis ans Ende der Liste kopiert, final dann jeweils die Werte einfügt.

Es sollen nur die Werte in den Zellen stehen, damit die Datei nicht träge wird.

Jetzt ist es aber so, dass die Laufzeit des Makros für die 121.000 Zeile 87 Minuten beträgt :-(

Gibt es im folgenden Makro Optimierungsmöglichkeiten, welche die Laufzeit des Makros verkürzen könnte?

Sub KopierenUndWerteEinfügen()
Dim lngLetzte As Long
Dim Bereich As Variant
Application.ScreenUpdating = False
lngLetzte = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row - 4
    For i = 1 To lngLetzte
    Range(Cells(4, 30), Cells(4, 50)).Copy Cells(4 + i, 30)     ' Für Formate einfügen
    Range(Cells(4 + i, 30), Cells(4 + i, 50)).Copy
    Cells(4 + i, 30).PasteSpecial Paste:=xlValues               ' Werte einfügen
    Next
Application.ScreenUpdating = True
Application.Calculation = xlCalculationAutomatic
Application.Calculate
End Sub

Bin für jeden Hinweis dankbar!

K.

Answer 1

Hallo,

meine letzte Nachricht wurde irgendwie nicht veröffentlicht, ich bin gerade dabei die Liste zu verkleinern und die Formeln zu ersetzen, indem ich gleich direkt die Ergebnisse berechnen lasse. Das Läuft viel effizienter als das Formel kopieren wie ursprünglich...

Mit einer Spalte habe ich jedoch Probleme, ich habe das einmal anonymisiert wie folgt dargestellt:

Sub ErgebnisEintragen()
For i = 2 To 13
If Cells(i, 5).Value > 0 And Cells(i, 4).Value = 0 Then
Cells(i, 7).Value = "entfernt"
End If
Next
End Sub

Es geht hier um die Spalte 7 (G).

Das Makro prüft mir schon mal ob der Inhalt in Spalte 5 > 0 und der Inhalt in Spalte 4 = 0 ist. Dann wird in der 7. Spalte der Text "entfernt" eingetragen.

Es soll aber nur dort "entfernt" eingetragen werden, wo das Datum in Spalte 6 nicht auch in der Tabelle "tbl_Termine" vorkommt. 

Entsprechen nämlich die 2 Werte und das Datum auch noch, dann soll dort eingetragen werden "bei Termin entfernt".

Kann mir hier bitte jemand helfen?

Diese Spalte fehlt mir noch in dem ganzen Spaltenkonvolut....

Danke vorab!!!
K.

Answer 2

Hi K.

Keine Ahnung ob ich dich richig verstanden habe, meinst du das etwa so?

Sub ErgebnisEintragen()

Dim rngTermine As Range
Set rngTermine = ActiveSheet.ListObjects("tbl_Termine").DataBodyRange

For i = 2 To 13
  If Cells(i, 5).Value > 0 And Cells(i, 4).Value = 0 _
  And IsError(Application.Match(Cells(i, 6), rngTermine, 0)) Then
    Cells(i, 7).Value = "entfernt"
  ElseIf Cells(i, 5).Value > 0 And Cells(i, 4).Value = 0 Then
    Cells(i, 7).Value = "bei Termin entfernt"
  End If
Next

End Sub

Allerdings wird 121000 mal der Schreibzugriff auf Cells(i, 7) auch ein paar Minuten dauern (schätzungsweise etwa 5 bis 7). Jedoch nur wenige Sekunden mit der Array-Lösung. Probier den Code oben und unten aus und ersetze die 13 durch deine Zeilenanzahl. Hier der gleiche Code mit Array:

Sub ErgebnisEintragen2()

Dim rngTermine As Range, arr() 'As String
Set rngTermine = ActiveSheet.ListObjects("tbl_Termine").DataBodyRange

ReDim arr(2 - 1 To 13 - 1, 1 To 1)

For i = 2 To 13
  If Cells(i, 5).Value > 0 And Cells(i, 4).Value = 0 _
  And IsError(Application.Match(Cells(i, 6), rngTermine, 0)) Then
    arr(i - 1, 1) = "entfernt"
  ElseIf Cells(i, 5).Value > 0 And Cells(i, 4).Value = 0 Then
    arr(i - 1, 1) = "bei Termin entfernt"
  End If
Next

Cells(2, 7).Resize(13 - 1, 1).Value = arr

End Sub

Gruß Mr. K.

Answer 3

Hallo nochmals,

jetzt bin ich soweit zufrieden mit den ganzen Durchläufen, ich denke zw. 4-5 Minuten für 120k Zeilen kann sich sehen lassen.... DANKE für eure Inputs und Lösungen dafür! *DANKE*

Jetzt stehe ich jedoch final for einem Problem, so dass ich die Zeilen unten im Screenshot noch als Auswertungsrelevant für eine weitere optische Darstellung aufbereiten muss.

Habe das mal anonymisiert dargestellt, es geht wie folgt um folgendes.

- MatNr kommt oftmals vor, hat auch Buchstaben am Ende
- Tagesdatum kommt auch öfters vor, Änderungsdatum und Zeit sowieso

Ich brauche nun am Ende eine Deklarierung, hab das mal als einfaches x dargestellt.

Benötigt wird jeweils von der Materialnummer der Datensatz, der als letzter geändert wurde.

Könnt ihr hier noch auf die Sprünge helfen, welchen Ansatz kann ich hier verfolgen?

Sub AuswertungsrelevanzMarkieren()
Dim lngLetzte, lngMatSpalte, lngDatumBedSpalte, lngDatumÄndSpale, lngUhrzeitSpalte, lngAusgabeSpalte As Long
lngLetzte = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
lngMatSpalte = 2
lngDatumBedSpalte = 6
lngDatumÄndSpalte = 14
lngUhrzeitSpalte = 15
lngAusgabeSpalte = 18

End Sub

Answer 4

Falls die Datensätze tatsächlich so schön geordnet wären (also nach Material dann Tagesdatum dan nÄnderungsDatum, dann Änderungszeit) ,wie im Screenshot dann ginge das simpel, denn dann muss ich ja nur je Material und Tagesdatum die letzte Zeile nehmen

z.B. in R3 =WENN(ODER(B3<>B4;F3<>F4);"x";"") und entsprechend runter ziehen

(oder in VBA FOr schleife über die zeilen IF Cells(zeile,2) <> Cells(zeile+1,2) Or Cells(zeile,6) <> Cells(zeile+1,6) Then Cells(zeile,18) = "x"

Falls nicht - dürfen sie geordnet werden ?

Ansonsten wären es wohl etliche Schleifen oder deutlich umfangreichere Formeln - zeitlich dann sicher suboptimal

Answer 5

Hallo,

ja, jetzt sind die Daten einwandfrei sortiert, aber man kann das ruhig einbauen, schadet ja nicht, dann ist es wenigstens immer so.

ich baue das dann einmal und melde mich dann nochmals... :-)

Answer 6

Hallo nochmals,

jetzt bin ich mit den Makros erstmal durch, folgendes hab ich final noch in das ganze Konvolut an Makros eingearbeitet.

Ich danke euch für eure immer wiederkehrende Unterstützung! *DANKE*

bg
K.

Sub TabelleSortieren()
Dim lngLetzte As Long
Dim rng As Range
lngLetzte = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
Set rng = Range(Cells(1, 1), Cells(lngLetzte, 17))
Worksheets("Datentabelle").Sort.SortFields.Clear
rng.Sort Key1:=Range("B1"), Key2:=Range("F1"), Key3:=Range("N1"), Header:=xlYes, _
    Order1:=xlAscending, Order2:=xlAscending, Order3:=xlAscending, DataOption1:=xlSortTextAsNumbers
End Sub

Sub AuswertungsrelevanzMarkieren()
Dim lngLetzte, lngMatSpalte, lngDatumBedSpalte, lngDatum�ndSpale, lngUhrzeitSpalte, lngAusgabeSpalte As Long
lngLetzte = ActiveSheet.Cells(Rows.Count, 2).End(xlUp).Row
lngMatSpalte = 2
lngDatumBedSpalte = 6
lngDatumaendSpalte = 14
lngUhrzeitSpalte = 15
lngAusgabeSpalte = 18
For j = 2 To lngLetzte
    If Cells(j, lngMatSpalte) <> Cells(j + 1, lngMatSpalte) Or Cells(j, lngDatumBedSpalte) <> Cells(j + 1, lngDatumBedSpalte) Then
    Cells(j, lngAusgabeSpalte) = "x"
    End If
Next j
End Sub

Answer 7

Moin K.

ganz allgemein und im Moment noch ohne konkrete Hilfe für Deine Tabelle: große Datenmengen lassen sich am besten direkt im RAM verarbeiten, in Deinem Fall in einem Array. Die Alternative Collection und Dictionary fallen hier weg. Die Berechnung findet dann nicht mehr in Lese/Schreibereien in den Ranges statt, sondern per VBA im RAM und es wird nur das Ergebnis in die Ranges ausgespuckt. Die Verarbeitungszeiten unterscheiden sich dann signifikant, wie Du mit den hier beschriebenen Methoden messen kannst.

Stell doch mal die Daten einer Zeile und ihre Formeln hier ein, dann kann man daraus vielleicht einen sinnvollen VBA-Code basteln.

Schöne Grüße

d'r Bastler von den VBAsteleien.de

Answer 8

Sorry! K.

ich war VOR meinem Beitrag oben auf Seite 1 der Posts hängengeblieben und hatte Deine weiteren Informationen nicht auf dem Schirm. Jetzt - denke ich- habe ich was gebraucht wird.

Bis Moin!

d'r Bastler von den VBAsteleien.de