CODEWITHSUNDEEP
vbaexcel
Gregory
Gregory

Reputation: 315

VBA/Excel timing out while trying to clean dataset

I have a report that adds a duplicated row below the last record with important information. I've tried to pull the the data into an array and run a nested loop to find the duplicates, copy the only piece of information needed to the relevant rows, and then mark that particular row for deletion; however, the loop keeps timing out as the dataset is ~10,000 rows.

Please see my code below:

Private Function MoveStatus2()

Dim eStatus As Variant
Dim arr() As Variant
Dim i As Long, x As Long, y As Long, lr As Long

lr = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

arr() = ActiveWorkbook.Sheets("FinancialReprt").Range(Cells(1, 22), Cells(lr, 25)).Value2

For i = 2 To UBound(arr())

    For x = UBound(arr()) To LBound(arr()) Step -1

        y = x

        If arr(i, 1) = arr(x, 1) And (Not i = x) And Not IsEmpty(arr(x, 4)) Then
            eStatus = arr(x, 4)

            Do Until y = i - 1

                arr(y, 4) = eStatus

            Loop

            If IsEmpty(arr(i, 2)) Then arr(x, 4) = "REMOVE"

        End If
    Next x
Next i

Worksheets.Add

ActiveSheet = Application.Transpose(arr())
End Function

Upvotes: 0

Views: 39

Answers (1)

Gregory
Gregory

Reputation: 315

Three issues with my original code:

1: the 'Do loop' was infinite because it was not decreasing with each iteration to reach the 'i loops' number.

2: the 'i loop' should have been set to the 'x loops' integer after the 'do loop', in order to pick up the checks where they they ended (the 'x loop' starts at the bottom row and works its way up, meanwhile the 'i loop' starts at the top row and works its way down)

3: The inner loop ('x loop') should have had instructions to exit once the checks were completed for the range between, and including, the 'x' and 'i loops'.

Code is below:

Private Function Update()

Dim eStatus As Variant
Dim arr() As Variant
Dim i As Long, x As Long, y As Long, lr As Long

lr = ActiveSheet.Cells(Rows.Count, 1).End(xlUp).Row

arr() = ActiveWorkbook.Sheets("FinancialReprt").UsedRange.Value2

For i = 2 To UBound(arr())
    For x = UBound(arr()) To LBound(arr()) Step -1
        y = x

        If arr(i, 22) = arr(x, 22) And (Not i = x) And Not IsEmpty(arr(x, 25)) Then

            eStatus = arr(x, 25)

            Do While y >= i

                arr(y, 25) = eStatus

                y = y - 1

            Loop

            If IsEmpty(arr(i, 23)) Then arr(x, 25) = "REMOVE"

            i = x

            Exit For

        End If
    Next x
Next i
End Function

Upvotes: 3

Related Questions