VBA Code Slown Down With Every Run

[hrayani]

Dear Friends,

I am using the below vba code which works absolutely fine but the only problem is it slows down after every run
when I open excel and run it for the first time it takes 100 milliseconds and then second time it takes 150 milliseconds and then third time it gets more slow
the problem is with the deletion part of the code - because I have tested my code removing the deletion part and the the code works absolutely fine
but as soon as the deletion part is inserted in the code it slows down with every run. It seems like it is storing something in the memory which is causing it to slow down. When I quit excel and start again then it runs ok but again slows down with every run
What exactly I don't know. Does anybody have an idea what is wrong or have experienced the same issue

the problem part

Dim delRange As Range, cell As Range

' Loop through column L in reverse (faster deletion)
For Each cell In wsDest.Range("L9:L" & lastRow)
    If cell.Value = 0 Then
        If delRange Is Nothing Then
            Set delRange = cell
        Else
            Set delRange = Union(delRange, cell)
        End If
    End If
Next cell

' Delete all rows in one go (if there are rows to delete)
If Not delRange Is Nothing Then delRange.EntireRow.Delete

FULL CODE

Sub GenerateUniqueListsOne()

ActiveSheet.Unprotect Password:="merchant"

Dim startTime As Double
Dim endTime As Double

' Start Timer
startTime = Timer * 1000

Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim dictQuality As Object, dictSupplier As Object, dictArticle As Object
    Dim arrQuality, arrSupplier, arrArticle, arrSampling
    Dim i As Long, lastRow As Long, outputRow As Long
    
    ' Set worksheets
    Set wsSrc = ThisWorkbook.Sheets("DATABASE")
    Set wsDest = ThisWorkbook.Sheets("Sample Wise")
    
lastRow = wsDest.Cells(wsDest.Rows.count, "B").End(xlUp).Row
    
If lastRow >= 9 Then
    wsDest.Range("A9:L" & lastRow).Clear
End If

    
    ' Load named ranges into arrays
    arrQuality = wsSrc.Range("orders_quality").Value
    arrSupplier = wsSrc.Range("orders_supplier").Value
    arrArticle = wsSrc.Range("orders_article").Value
    arrSampling = wsSrc.Range("orders_sampling").Value
    
    ' Initialize dictionaries
    Set dictQuality = CreateObject("Scripting.Dictionary")
    Set dictSupplier = CreateObject("Scripting.Dictionary")
    Set dictArticle = CreateObject("Scripting.Dictionary")
    
    ' Populate dictionaries with unique values where orders_sampling is not empty
    For i = 1 To UBound(arrQuality, 1)
        If Trim(arrSampling(i, 1)) <> "" Then
            If Not dictQuality.Exists(arrQuality(i, 1)) Then dictQuality(arrQuality(i, 1)) = True
            If Not dictSupplier.Exists(arrSupplier(i, 1)) Then dictSupplier(arrSupplier(i, 1)) = True
            If Not dictArticle.Exists(arrArticle(i, 1)) Then dictArticle(arrArticle(i, 1)) = True
        End If
    Next i
    
    ' Convert dictionaries to sorted arrays
    Dim arrSortedQuality, arrSortedSupplier, arrSortedArticle
    arrSortedQuality = SortArray(dictQuality.Keys)
    arrSortedSupplier = SortArray(dictSupplier.Keys)
    arrSortedArticle = SortArray(dictArticle.Keys)
    
    ' Write data to Sheet1 starting from B9
    outputRow = 9
    wsDest.Range("B" & outputRow).Resize(UBound(arrSortedQuality) + 1, 1).Value = Application.Transpose(arrSortedQuality)
    outputRow = outputRow + UBound(arrSortedQuality) + 1
    wsDest.Range("B" & outputRow).Resize(UBound(arrSortedSupplier) + 1, 1).Value = Application.Transpose(arrSortedSupplier)
    outputRow = outputRow + UBound(arrSortedSupplier) + 1
    wsDest.Range("B" & outputRow).Resize(UBound(arrSortedArticle) + 1, 1).Value = Application.Transpose(arrSortedArticle)
    
    
    ' Define starting row for labels (same as where data starts)
Dim labelRow As Long
labelRow = 9

' Add labels in column A next to each list
wsDest.Range("A" & labelRow & ":A" & (labelRow + UBound(arrSortedQuality))).Value = "Quality"
labelRow = labelRow + UBound(arrSortedQuality) + 1
wsDest.Range("A" & labelRow & ":A" & (labelRow + UBound(arrSortedSupplier))).Value = "Supplier"
labelRow = labelRow + UBound(arrSortedSupplier) + 1
wsDest.Range("A" & labelRow & ":A" & (labelRow + UBound(arrSortedArticle))).Value = "Article"

    ' Cleanup
    Set dictQuality = Nothing
    Set dictSupplier = Nothing
    Set dictArticle = Nothing
    

' Recalculate lastRow after inserting data
lastRow = wsDest.Cells(wsDest.Rows.count, "B").End(xlUp).Row

Dim formulaRng As Range
Set formulaRng = wsDest.Range("C9:J" & lastRow) ' Define the range to apply the first formula

' Apply the first formula
formulaRng.Formula = "=SUMIFS(IF(C$8=""QUANTITY"",orders_quantity,orders_value),orders_sampling,IF(ISBLANK(C$3),""*""&B$3&""*"",""*""&C$3&""*""),IF($A9=""Quality"",orders_quality,IF($A9=""Article"",orders_article,orders_supplier)),$B9,orders_supplier,IF($G$1=""ALL"",""*"",$G$1))/IF(C$8=""Quantity"",1,1000000)"

' Convert first formula to values
formulaRng.Value = formulaRng.Value

' Apply the second formula in K9:L(lastRow)
Dim sumifRng As Range
Set sumifRng = wsDest.Range("K9:L" & lastRow)

sumifRng.Formula = "=SUMIF($C$8:$J$8,K$8,$C9:$J9)"

' Convert second formula to values
sumifRng.Value = sumifRng.Value

Application.Calculation = xlCalculationAutomatic




Dim delRange As Range, cell As Range

' Loop through column L in reverse (faster deletion)
For Each cell In wsDest.Range("L9:L" & lastRow)
    If cell.Value = 0 Then
        If delRange Is Nothing Then
            Set delRange = cell
        Else
            Set delRange = Union(delRange, cell)
        End If
    End If
Next cell

' Delete all rows in one go (if there are rows to delete)
If Not delRange Is Nothing Then delRange.EntireRow.Delete

' Apply number formatting
Dim formatRange As Range

' Define last row again after all processing
lastRow = wsDest.Cells(wsDest.Rows.count, "B").End(xlUp).Row

If lastRow >= 9 Then

' Apply format to numeric columns
Set formatRange = wsDest.Range("C9:C" & lastRow & ",E9:E" & lastRow & ",G9:G" & lastRow & ",I9:I" & lastRow & ",K9:K" & lastRow)
formatRange.NumberFormat = "#,##0 ;[<0]-#,##0 ;""-"""

' Apply format to currency columns (display as "$ 0.00 M")
Set formatRange = wsDest.Range("D9:D" & lastRow & ",F9:F" & lastRow & ",H9:H" & lastRow & ",J9:J" & lastRow & ",L9:L" & lastRow)
formatRange.NumberFormat = """$"" 0.00\ ""M"" ;""-$""0.00\ ""M"" ;-"

End If

' Apply center alignment to C9:L(lastRow)
wsDest.Range("C9:L" & lastRow).HorizontalAlignment = xlCenter

With wsDest.Range("B9:L" & lastRow)

    .VerticalAlignment = xlCenter
    .BorderAround Color:=RGB(166, 166, 166), Weight:=xlMedium
    .Borders(xlInsideVertical).Color = RGB(166, 166, 166)
    .Borders(xlInsideVertical).Weight = xlThin
    .Borders(xlInsideHorizontal).Color = RGB(166, 166, 166)
    .Borders(xlInsideHorizontal).Weight = xlThin
    .Borders(xlEdgeTop).LineStyle = xlNone

End With

' Apply vertical borders around fixed column pairs (C&D, E&F, G&H, I&J, K&L)
Dim col As Integer
For col = 3 To 11 Step 2  ' Column 3 (C) to Column 11 (K), ensuring L is paired
    wsDest.Range(wsDest.Cells(9, col), wsDest.Cells(lastRow, col + 1)).BorderAround Color:=RGB(166, 166, 166), Weight:=xlMedium
Next col

' End Timer
endTime = Timer * 1000

' Store Time Taken in H1 (Milliseconds)
wsDest.Range("H1").Value = Round(endTime - startTime, 0) & " ms"


ActiveSheet.Protect Password:="merchant"


Application.ScreenUpdating = False
End Sub

Function SortArray(arr As Variant) As Variant
    Dim temp As Variant, i As Long, j As Long
    Dim sortedArr() As Variant
    sortedArr = arr
    
    ' Bubble sort for small datasets (fast and simple)
    For i = LBound(sortedArr) To UBound(sortedArr) - 1
        For j = i + 1 To UBound(sortedArr)
            If sortedArr(i) > sortedArr(j) Then
                temp = sortedArr(i)
                sortedArr(i) = sortedArr(j)
                sortedArr(j) = temp
            End If
        Next j
    Next i
    
    SortArray = sortedArr
End Function

 

[LegendaryAxe]

Have you tried "Set delrange = Nothing" at the end of the code? When you say it seems like VBA is storing something in memory, that's what it could be.

 

[hrayani]

Yes I tried - but the problem remains there
It still slows down with every run

 

[pcc]

How about a simple 'End' statement. That should clear out all variables and arrays etc (I think)

 

[StephenCrump]

Your are measuring lastRow on column B. And it looks like your code is adding rows to column B.

So isn't the reason the code slows down with every iteration the fact that lastRow is growing, so that are you looping through more cells?

(Rather than loop, I'd filter for zero values in column L, and delete the filtered rows).

 

[hrayani]

Your are measuring lastRow on column B. And it looks like your code is adding rows to column B.

So isn't the reason the code slows down with every iteration the fact that lastRow is growing, so that are you looping through more cells?

(Rather than loop, I'd filter for zero values in column L, and delete the filtered rows).

Hello Stephen,

Thanks for the reply

I tried many options but found the same issue with every approach. Yes, I tried the filter method also, but it did not serve the purpose either.

Finally, I tweaked the code to hide the rows with zero values because at the end of the day this is what I wanted (means I wanted to get rid of the zero values).
So it's a work around I would say - rather than getting to the core of the problem & getting it solved as it was not easy for me as I have very little knowledge of VBA - rather next to none I should say.

Still Learning

Regards,

Humayun

 

[kvsrinivasamurthy]

Try. Replace This

' Loop through column L in reverse (faster deletion)
For Each cell In wsDest.Range("L9:L" & lastRow)
    If cell.Value = 0 Then
        If delRange Is Nothing Then
            Set delRange = cell
        Else
            Set delRange = Union(delRange, cell)
        End If
    End If
Next cell

' Delete all rows in one go (if there are rows to delete)
If Not delRange Is Nothing Then delRange.EntireRow.Delete

By

Dim T&, S$, M
M = Filter(Evaluate("transpose(If('" & wsDest.Name & "'!L9:L" & lastrow & "=0,row(L9:L" & lastrow & "),false))"), False, False)
If UBound(M) >= 0 Then
For T = UBound(M) To 0 Step -1
S = S & "," & "L" & M(T)
If Len(S) > 240 Or T = 0 Then
Range(Mid(S, 2)).EntireRow.Delete
S = ""
End If
Next T
End If

 

[Alex Blakenburg]

If you want to try a different approach. On a copy of your workbook.

Replace this:

Dim delRange As Range, cell As Range

' Loop through column L in reverse (faster deletion)
For Each cell In wsDest.Range("L9:L" & lastRow)
    If cell.Value = 0 Then
        If delRange Is Nothing Then
            Set delRange = cell
        Else
            Set delRange = Union(delRange, cell)
        End If
    End If
Next cell

' Delete all rows in one go (if there are rows to delete)
If Not delRange Is Nothing Then delRange.EntireRow.Delete

With this:

DeleteRows wsDest.Range("L9:L" & lastRow)

And add this Sub

Sub DeleteRows(rngCriteria As Range)
    Dim wsDel As Worksheet
    Dim rowHdg As Long, colNext As Long
    Dim arrCrit As Variant, arrDel As Variant
    Dim i As Long, iDel As Long
    
    Set wsDel = rngCriteria.Parent
    arrCrit = rngCriteria.Value
    rowHdg = rngCriteria.Row - 1
    
    With wsDel
        colNext = .Cells(rowHdg, Columns.Count).End(xlToLeft).Column + 1
    End With
    
    ReDim arrDel(1 To UBound(arrCrit), 1 To 1)
    
    For i = 1 To UBound(arrCrit)
        If arrCrit(i, 1) = 0 Then
            arrDel(i, 1) = 1
            iDel = iDel + 1
        End If
    Next i
    
    ' If no of rows to be deleted is not 0 take deletion steps
      If iDel > 0 Then
        ' Resize range to the same size as data which is the original no of rows and Last Column + 1 (having added a column for arrDel array)
        With wsDel
            With .Cells(rowHdg + 1, "A").Resize(UBound(arrCrit), colNext)
              .Columns(colNext).Value = arrDel
            ' Sort range so that the 1s in the new column go to the top
              .Sort Key1:=.Columns(colNext), Order1:=xlAscending, Header:=xlNo
              .Resize(iDel).EntireRow.Delete    
            End With
        End With
     End If
End Sub