VBA Code Slown Down With Every Run

H

hrayani

Well-known Member
Joined
Jul 23, 2010
Messages
1,551
Office Version
  1. 2016
Platform
  1. Windows
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
VBA Code: 
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

VBA 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
 
Sort by date Sort by votes
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.
 
Upvote 0
You must log in or register to reply here.

Similar threads

C
  • Question Question
VBA code for new workbook extraction with data grouping
Replies
0
Views
25
coding123456
C
B
  • Question Question
Run-time error 1004 method range of object worksheet railed
Replies
2
Views
172
Joe4
Joe4
I
  • Solved
Trying to open userform & run code from worksheet but see a compile error message
Replies
4
Views
119
ipbr21054
I
neilp
  • Solved
Tweak to VBA code to include last line
Replies
6
Views
92
Joe4
Joe4
U
  • Solved
Rewrite Code as a Sub to work on Active Sheet
Replies
2
Views
222
Skyybot
Skyybot

Forum statistics

Threads
1,226,837
Messages
6,193,253
Members
453,784
Latest member
Chandni

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top