Diese Schleife läuft grottenlangsam

Sub LastDurchlauf() Application.ScreenUpdating = False Application.Calculation = xlCalculationManual Application.EnableEvents = False Set Main = Sheets("Main") lrow = Range("C1000000").End(xlUp).Row For i = 5 To lrow For y = i - 1 To 4 Step -1 If Cells(y, 3) = Cells(i, 3) Then Cells(i, 57) = i - y Exit For End If If i - y > 30 Then Cells(i, 57) = "X" Exit For End If Next y For x = i + 1 To lrow If Cells(x, 3) > Cells(i, 3) - 2 And Cells(x, 3) 30 Then Cells(i, 58) = "X" Exit For End If Next x Range("I1") = i Application.ScreenUpdating = True Application.ScreenUpdating = False Next i Application.EnableEvents = True Application.Calculation = xlCalculationAutomatic Application.ScreenUpdating = True End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Benutzer

Hallo,
versuch es mal so:


Public Sub LastDurchlauf()
    
    Dim lngLastRow As Long, lngMainRow As Long
    Dim lngSubRow1 As Long, lngSubRow2 As Long
    Dim vntInputArray As Variant
    Dim vntOutputArray1 As Variant, vntOutputArray2 As Variant
    
    lngLastRow = Cells(Rows.Count, 3).End(xlUp).Row
    vntInputArray = Range(Cells(1, 3), Cells(lngLastRow, 3)).Value2
    vntOutputArray1 = Range(Cells(1, 57), Cells(lngLastRow, 57)).Value2
    vntOutputArray2 = Range(Cells(1, 58), Cells(lngLastRow, 58)).Value2
    
    For lngMainRow = 5 To lngLastRow
        For lngSubRow1 = lngMainRow - 1 To 4 Step -1
            If vntInputArray(lngSubRow1, 1) = vntInputArray(lngMainRow, 1) Then
                vntOutputArray1(lngMainRow, 1) = lngMainRow - lngSubRow1
                Exit For
            End If
            If lngMainRow - lngSubRow1 > 30 Then
                vntOutputArray1(lngMainRow, 1) = "X"
                Exit For
            End If
        Next lngSubRow1
        For lngSubRow2 = lngMainRow + 1 To lngLastRow
            If vntInputArray(lngSubRow2, 1) > vntInputArray(lngMainRow, 1) - 2 Then
                If vntInputArray(lngSubRow2, 1) < vntInputArray(lngMainRow, 1) + 2 Then
                    vntOutputArray2(lngMainRow, 1) = lngSubRow2 - lngMainRow
                    Exit For
                End If
            End If
            If lngSubRow2 > 30 Then
                vntOutputArray2(lngMainRow, 1) = "X"
                Exit For
            End If
        Next lngSubRow2
    Next lngMainRow
    
    With Application
        .ScreenUpdating = False
        .Calculation = xlCalculationManual
        .EnableEvents = False
    End With
    
    Range(Cells(1, 57), Cells(lngLastRow, 57)).Value2 = vntOutputArray1
    Range(Cells(1, 58), Cells(lngLastRow, 58)).Value2 = vntOutputArray2
    
    With Application
        .EnableEvents = True
        .Calculation = xlCalculationAutomatic
        .ScreenUpdating = True
    End With
End Sub

Gruß
Nepumuk

Beliebteste Forumthreads (12 Monate)

Diese Schleife läuft grottenlangsam

2 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

2
Beiträge zum Forumthread

Beiträge zu diesem Forumthread