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