CODEWITHSUNDEEP
arraysexcelvbafor-loop
Boomer215
Boomer215

Reputation: 11

Removing duplicates in a for loop crashes Excel

I have a for next loop that runs through a couple hundred thousand lines making changes on most. Could an array to make this code run faster?

The example of my for loop. Sometimes it gets overloaded and crashes Excel. (FYI my loop has to run bottom to top for it to do its intended purpose.)

Sub RemoveDuplicates()

Dim shWorkBook As Worksheet
Dim wkb As Workbook
Dim FullYearData As Worksheet
Set wkb = ThisWorkbook

With wkb
    Set shWorkBook = .Sheets("Workbook")
    Set shFullYearData = .Sheets("FullYearData")
End With

Dim i As Long
Dim LastRowW As Long

On Error Resume Next

Call TurnOffCalc

FirstRowW = shWorkBook.Cells(1, 1).Row
FirstColW = shWorkBook.Cells(1, 1).Column
LastRowW = shWorkBook.Cells(Rows.Count, 1).End(xlUp).Row
LastColW = shWorkBook.Cells(2, Columns.Count).End(xlToLeft).Column

i = LastRowW

Sum = 0
shWorkBook.Activate

For i = LastRowW To 1 Step -1
    If shWorkBook.Cells(i, 7) = shWorkBook.Cells(i - 1, 7) Then
        shWorkBook.Cells(i, 26) = vbNullString
    End If
    
    If shWorkBook.Cells(i, 26).Value <> "" Then
        shWorkBook.Cells(i, 27) = Sum + Cells(i, 25).Value
        Sum = 0
    ElseIf shWorkBook.Cells(i, 26).Value = "" Then

        Sum = shWorkBook.Cells(i, 25).Value + Sum
    End If
Next

p = FirstRowW + 1
For p = FirstRowW + 1 To LastRowW Step 1
    shWorkBook.Cells(p, 28) = Application.WeekNum(shWorkBook.Cells(p, 3))
Next

shWorkBook.Cells(1, 28).Value = "Week Number"
Call TurnOnCalc
 
End Sub

Upvotes: 0

Views: 112

Answers (1)

Tim Williams
Tim Williams

Reputation: 166735

Try something like this:

Sub RemoveDuplicates()

    Dim shWorkBook As Worksheet
    Dim wkb As Workbook
    Dim FullYearData As Worksheet
    Dim i As Long, Sum
    Dim LastRowW As Long, LastColW As Long, tbl As Range, data
    
    
    Set wkb = ThisWorkbook
    With wkb
        Set shWorkBook = .Sheets("Workbook")
        'Set shFullYearData = .Sheets("FullYearData")
    End With
    
    LastRowW = shWorkBook.Cells(Rows.Count, 1).End(xlUp).Row
    LastColW = shWorkBook.Cells(2, Columns.Count).End(xlToLeft).Column
    
    Set tbl = shWorkBook.Range("A1").Resize(LastRowW, 28) 'include "Week number" (?)
    data = tbl.Value 'get the range value as an array
    data(1, 28) = "Week Number"

    Sum = 0
    For i = LastRowW To 1 Step -1
        
        If data(i, 7) = data(i - 1, 7) Then data(i, 26) = vbNullString
        
        If data(i, 26).Value <> "" Then
            data(i, 27) = Sum + data(i, 25).Value
            Sum = 0
        Else
            Sum = data(i, 25).Value + Sum
        End If
        
        If i > 1 Then data(i, 28) = CLng(Format(data(i, 3), "ww"))
        
    Next

    tbl.Value = data 'return the data

End Sub

Upvotes: 1

Related Questions