Eine VBA-Schleife schneller berechnen lassen

Question

Ich habe mehrere Varianten probiert, aber die Schleifen brauchen bei meinen Varianten immer über eine Minute. 

Application.ScreenUpdating = False

Application.ScreenUpdating = True

Habe ich auch integriert.

Okay, die Aufgabe der Schleife ist nicht ohne, m=Montage hat 17 verschiedene  Kostenstellen, und f= fertigung hat fünf verschiedene Kostenstellen. All diese Kostenstellen sind in der Spalte H37:H649. Die Kostenstellen sind in der Spalte vermischt. Es gibt keine Ordnung. Die Schleife soll "k" und "K" (Krank) entsprechend der Montage und der Fertigung nach KW zählen .Die KW sind in dem Quellarbeitsblatt "Abwesenheiten" in "Z30:NZ30". Die KW von 1 bis 52 sind in "B1:BA1" in der Zieldatei. Das Ergebnis der Montage wir in "B5:BA5" dargestellt. Das Ergebnis der Fertigung findet sich in "B6:BA6".

Wie geschrieben die Schleifen funktionieren, aber jede einzelne von Ihnen knapp über eine Minute. Ich habe die Zeit gestoppt.

Kann man meine Schleifen optimieren? 

Bedanke mich im Voraus für die Unterstützung.

 

Schleife 1 

    For i = 2 To 53
        count = 0
        For col = 26 To 390
            If ws1.Cells(30, col).value = ws2.Cells(1, i).value Then
                For row = 37 To 649

                    For Each m In montage
                        If UCase(ws1.Cells(row, col).value) = "K" And ws1.Cells(row, "H").value = m Then count = count + 1
                    Next m
                Next row
            End If
        Next col
' Hier wird das Ergebnis in Zielarbeitsblatt geschrieben in B5:BA5
        ws2.Cells(5, i).value = count
    Next i

    For i = 2 To 53
        count = 0
        For col = 26 To 390
            If ws1.Cells(30, col).value = ws2.Cells(1, i).value Then
                For row = 37 To 649

                    For Each f In fertigung
                        If UCase(ws1.Cells(row, col).value) = "K" And ws1.Cells(row, "H").value = f Then count = count + 1
                    Next f
                Next row
            End If
        Next col
        ' Hier wird das Ergebnis in Zielarbeitsblatt geschrieben in B6:BA6
        ws2.Cells(6, i).value = count
    Next i

Schleife 2

' Konstanten für bessere Lesbarkeit
    Const START_ROW As Long = 37
    Const END_ROW As Long = 649
    Const START_COL As Long = 26
    Const END_COL As Long = 390

' Schleife für Montage
    For i = 2 To 53
        count = 0
        For col = START_COL To END_COL
            If ws1.Cells(30, col).value = ws2.Cells(1, i).value Then
                For row = START_ROW To END_ROW
                    Dim m As Variant
                    For Each m In montage
                        If UCase(ws1.Cells(row, col).value) = "K" And ws1.Cells(row, "H").value = m Then count = count + 1
                    Next m
                Next row
            End If
        Next col
        ' Ergebnis in Zielarbeitsblatt schreiben
        ws2.Cells(5, i).value = count
    Next i

    ' Schleife für Fertigung
    For i = 2 To 53
        count = 0
        For col = START_COL To END_COL
            If ws1.Cells(30, col).value = ws2.Cells(1, i).value Then
                For row = START_ROW To END_ROW
                    Dim f As Variant
                    For Each f In fertigung
                        If UCase(ws1.Cells(row, col).value) = "K" And ws1.Cells(row, "H").value = f Then count = count + 1
                    Next f
                Next row
            End If
        Next col
        ' Hier wird das Ergebnis in Zielarbeitsblatt geschrieben
        ws2.Cells(6, i).value = count
    Next i

Schleife 3

Dim data As Variant
data = ws1.Range(ws1.Cells(30, 26), ws1.Cells(649, 390)).value

For i = 2 To 53
    count = 0
    For col = 26 To 390
        If data(1, col) = ws2.Cells(1, i).value Then
            For row = 37 To 649
                For Each m In montage
                    If UCase(data(row, col)) = "K" And data(row, "H") = m Then count = count + 1
                Next m
            Next row
        End If
    Next col

' Hier wird das Ergebnis in Zielarbeitsblatt geschrieben

    ws2.Cells(5, i).value = count
Next i

For i = 2 To 53
    count = 0
    For col = 26 To 390
        If data(1, col) = ws2.Cells(1, i).value Then
            For row = 37 To 649
                For Each f In montage
                    If UCase(data(row, col)) = "K" And data(row, "H") = f Then count = count + 1
                Next f
            Next row
        End If
    Next col
    '

' Hier wird das Ergebnis in Zielarbeitsblatt geschrieben

    ws2.Cells(6, i).value = count
Next i

Answer 1

Hallo zagor,
bei verschachtelten Schleifen ist in erster Linie die innerste Ebene von Bedeutung für die Optimierung.
Ich habe es aber mal überschlagen du hast zwei Hauptteile, deren innersten Ebene jeweils fast 200 Millionen Mal durchlaufen wird
Selbst wenn die beiden innersten Ebenen sehr schnell bearbeitet werden,  wird es in Summe doch erheblich Zeit benötigen.

Gruß computerschrat

Answer 2

Hi Zagor,

überleg nochmal. Brauchst du wirklich 4 ineinander verschachtelte Schleifen? Allein die oberen drei i, col und row ergeben (53 - 2) * (390 - 26) * (649 - 37), also fast 11,4 Mio. Schleifendurchläufe. Und das noch multipliziert mit der Anzahl der Montage. Sowas dauert nun mal seine Zeit.

Dein Anliegen sollte mit nur zwei verschachtelten Schleifen (row, col) und ein paar mehr If-Bedingungen ebenfalls lösbar sein. Ohne eine Beispieltabelle mit passenden Soll-Ergebnissen kann ich hier aber nicht viel mehr sagen.

Tipp: Ein bisschen sollte dir auch der Befehlt Exit For weiterhelfen. Damit kannst du nach erfolgter Prüfung  einer Bedingung irgendwo eine Schleife vorzeitig abbrechen. Aber die Zweierschleife sollte hier mehr Zeitersparnis ergeben.

Gruß Mr. K.

Answer 3

Gleiche Idee, aber Computerschrat war schneller. Die Anzahl 17 bei den Montagen hatte ich doch glatt überlesen. Ja 200 Mio. ist schon ne Hausnummer.

Gruß an  @Computerschrat

Answer 4

Vielen Dank für dien Hinweis zum Thema "verschachtelte Schleife".

Jetzt ist die Schleife bei 10 Sekunden.

Set kostenstellen = CreateObject("Scripting.Dictionary")
For Each m In montage
    kostenstellen.Add m, "montage"
Next m
For Each f In fertigung
    kostenstellen.Add f, "fertigung"
Next f

' Durchlaufen der Zeilen und Spalten nur einmal
For i = 2 To 53
    countMontage = 0
    countFertigung = 0
    For col = 26 To 390
        If ws1.Cells(30, col).value = ws2.Cells(1, i).value Then
            For row = 37 To 649
                ' Überprüfe, ob die aktuelle Zelle eine Kostenstelle ist
                If UCase(ws1.Cells(row, col).value) = "K" And kostenstellen.Exists(ws1.Cells(row, "H").value) Then
                    If kostenstellen(ws1.Cells(row, "H").value) = "montage" Then
                        countMontage = countMontage + 1
                    ElseIf kostenstellen(ws1.Cells(row, "H").value) = "fertigung" Then
                        countFertigung = countFertigung + 1
                    End If
                End If
            Next row
        End If
    Next col
    ' Ergebnisse in das Zielarbeitsblatt in die Zeilen 5 & 6
    ws2.Cells(5, i).value = countMontage
    ws2.Cells(6, i).value = countFertigung
Next i

Answer 5

eventuell bringt das noch was (wobei ich mal annehme, dass in ws2.Cells(1, i).Value die Kalenderwoche also eine ganze Zahl steht und damit ein array ansprechbar ist

Set kostenstellen = CreateObject("Scripting.Dictionary")

For Each m In montage
    kostenstellen.Add m, "montage"
Next m
For Each f In fertigung
    kostenstellen.Add f, "fertigung"
Next f

' Durchlaufen der Zeilen und Spalten nur einmal
For i = 2 To 53
    countMontage(ws2.Cells(1, i).Value) = 0
    countFertigung(ws2.Cells(1, i).Value) = 0
Next i
For Row = 37 To 649
   If kostenstellen.Exists(ws1.Cells(Row, "H").Value) Then
        For col = 26 To 390
            
                ' Überprüfe, ob die aktuelle Zelle eine Kostenstelle ist
                If UCase(ws1.Cells(Row, col).Value) = "K" Then
                    If kostenstellen(ws1.Cells(Row, "H").Value) = "montage" Then
                        countMontage(ws1.Cells(30, col).Value) = countMontage(ws1.Cells(30, col).Value) + 1
                    ElseIf kostenstellen(ws1.Cells(Row, "H").Value) = "fertigung" Then
                        countFertigung(ws1.Cells(30, col).Value) = countFertigung(ws1.Cells(30, col).Value) + 1
                    End If
                End If
        Next col
    End If
Next Row
    ' Ergebnisse in das Zielarbeitsblatt in die Zeilen 5 & 6
For i = 2 To 53
    ws2.Cells(5, i).Value = countMontage(i)
    ws2.Cells(6, i).Value = countFertigung(i)
Next i

Answer 6

eventuell bringt das noch was (wobei ich mal annehme, dass in ws2.Cells(1, i).Value die Kalenderwoche also eine ganze Zahl steht und damit ein array ansprechbar ist - ansonsten wird es einen Fehler bringen

Set kostenstellen = CreateObject("Scripting.Dictionary")

For Each m In montage

kostenstellen.Add m, "montage"

Next m

For Each f In fertigung

kostenstellen.Add f, "fertigung"

Next f

' Durchlaufen der Zeilen und Spalten nur einmal

For i = 2 To 53

countMontage(ws2.Cells(1, i).Value) = 0

countFertigung(ws2.Cells(1, i).Value) = 0

Next i

For Row = 37 To 649

If kostenstellen.Exists(ws1.Cells(Row, "H").Value) Then

For col = 26 To 390

' Überprüfe, ob die aktuelle Zelle eine Kostenstelle ist

If UCase(ws1.Cells(Row, col).Value) = "K" Then

If kostenstellen(ws1.Cells(Row, "H").Value) = "montage" Then

countMontage(ws1.Cells(30, col).Value) = countMontage(ws1.Cells(30, col).Value) + 1

ElseIf kostenstellen(ws1.Cells(Row, "H").Value) = "fertigung" Then

countFertigung(ws1.Cells(30, col).Value) = countFertigung(ws1.Cells(30, col).Value) + 1

End If

End If

Next col

End If

Next Row

' Ergebnisse in das Zielarbeitsblatt in die Zeilen 5 & 6

For i = 2 To 53

ws2.Cells(5, i).Value = countMontage(i)

ws2.Cells(6, i).Value = countFertigung(i)

Next i

Answer 7

Ja, der Codeabschnitt führt zu einem Fehler "Erwartet: Datenfeld". Danke für den Vorschlag..

Answer 8

Stimmt das hätte ich noch anmerken sollen (weil die Definition (Dim)) der Variablen nicht in dem Bereich ist)

man muss countMontage und countFertigung dann noch so definieren

Dim CountMonatge (1 to 53)  AS Integer

Dim CountFertigung (1 to 53)  AS Integer

weil sie ja nun als Array verwendet werden

Answer 9

Vielen Dank . 

    Dim countMontage As Object, countFertigung As Object
    Set countMontage = CreateObject("Scripting.Dictionary")
    Set countFertigung = CreateObject("Scripting.Dictionary")


    ' Ergebnisse in das Zielarbeitsblatt in die Zeilen 5 & 6
For i = 2 To 53
    ws2.Cells(5, i).value = countMontage(ws2.Cells(1, i).value)
    ws2.Cells(6, i).value = countFertigung(ws2.Cells(1, i).value)
Next i

Die Anpassung des VBA-Codes brachte 2 Sekunden. Jetzt braucht das Makro für die ganzen Aufgaben (mehrere Aufgaben) 8:40 Sekunden. Das ist gut .