My Worksheet_Change Event is very slow

D

Drawleeh

New Member
Joined
Sep 2, 2021
Messages
34
Office Version
  1. 2016
  2. 2010
Platform
  1. Windows
Okay so I kind of know why its slow and I will explain but, I'm hoping there is a kind soul out there who can help me make it less so. So in regards to what my code actually does. When values in 3 adjacent cells in columns C,D and E are entered, the date of entry is recorded in a separate sheet as well as the sheet where the data was input in. Then it counts all instances of the date input and outputs the total in a calendar essentially calculating how many times per day values were entered into any adjacent C,D and E group of cells.

But the issue is, its really slow, and I think this is because I'm dumb and coded this wrong;

Anyway here is the code:

VBA Code: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Const fRow As Long = 2
    Const cCols As String = "C:E"
    
    Const dName As String = "Log"
    Const dCol As String = "A"
    Const dcCol As String = "C"
    
    Dim crg As Range
    Set crg = Columns(cCols).Resize(Rows.Count - fRow + 1).Offset(fRow - 1)
    Dim irg As Range: Set irg = Intersect(crg, Target)

    If irg Is Nothing Then Exit Sub
    
    Dim srg As Range: Set srg = Intersect(irg.EntireRow, crg)
    Dim sName As String: sName = ActiveSheet.Name
     
    Dim dws As Worksheet: Set dws = Worksheets(dName)
    Dim dfCell As Range: Dim ddcrg As Range: Set ddcrg = dws.Columns(dcCol)
    
    Dim arg As Range
    Dim rrg As Range
    Dim srAddress As String
    Dim ddFound As Range
    
    For Each arg In srg.Areas
        For Each rrg In arg.Rows
            srAddress = sName & "!" & rrg.Address(0, 0)
            Set ddFound = ddcrg.Find(srAddress, , xlFormulas, xlWhole)
            If Application.CountBlank(rrg) = 0 Then
                If ddFound Is Nothing Then
                With Sheets("Log")
                    Set dfCell = dws.Cells(dws.Rows.Count, dCol) _
                        .End(xlUp).Offset(1)
                        dfCell.Value = Format(Date, "mm/dd/yyyy")
                        dfCell.Offset(, 1).Value = ActiveSheet.Name
                        dfCell.Offset(, 2).Value = srAddress
                        
                        Dim arrDates As Range
                        Dim LastRow As Long
                        Dim DateRange As Long
                        Dim RowCount As Long
                        Dim ClmnAmnt As Long
                        Dim ClmnDate() As Variant
                        Dim AddrArr() As Variant
                        Dim ClmnNmbr As Long
                        Dim shtNames As Range
                        Dim TypCount As Long
                        Dim FrstLetter() As Variant
                        Dim SheetIdent As String
                        Dim lastAddrs As String
                        
                        With Sheets("Log")
                        For RowCount = 1 To 60
                            Select Case RowCount
                                Case 2, 7, 12, 17, 22, 27, 32, 37, 42, 47, 52, 57
                                LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
                                DateRange = WorksheetFunction.CountA(.Range("F" & RowCount & ":AJ" & RowCount))
                                    For TypCount = 1 To 3
                                        SheetIdent = .Cells(RowCount + TypCount, 5).Value
                                            For ClmnNmbr = 1 To DateRange
                                            
                                                ReDim AddrArr(DateRange)
                                                AddrArr(ClmnNmbr) = .Cells(RowCount, ClmnNmbr + 5).Value
                                                
                                                Set arrDates = .Range("A60:A" & LastRow)
                                                Set shtNames = .Range("B60:B" & LastRow)
                                                
                                                
                                                
                                                ReDim FrstLetter(DateRange)
                                                FrstLetter(ClmnNmbr) = Application.CountIfs(arrDates, AddrArr(ClmnNmbr), shtNames, SheetIdent)
                                                
                                                Worksheets("Log").Cells(TypCount + RowCount, ClmnNmbr + 5).Value = Application.Transpose(FrstLetter(ClmnNmbr))
                                                
                                                
                                            Next ClmnNmbr
                                     Next TypCount
                                Case Else
                            End Select
                        Next RowCount
                        
                        End With
                        
                        Dim wkb1 As Workbook
                        Dim sht1 As Worksheet
                        Dim wkb2 As Workbook
                        Dim sht2 As Worksheet
    
                        Application.ScreenUpdating = False

                        Set wkb1 = Workbooks("Letters Log_2022.xlsm")
                        Set wkb2 = Workbooks.Open("H:\Branches\DACH067\Customs\Customs TRANSIT\Transit stats\Admin Output.xlsx")
                        Set sht1 = wkb1.Sheets("Log")
                        Set sht2 = wkb2.Sheets("Statistics")
                        
                        sht1.Range("E1:AL60").Copy
                        sht2.Range("A1").PasteSpecial xlPasteValues
                        Application.CutCopyMode = False
                        wkb2.Close True

                        Application.ScreenUpdating = True
    
                        End With
                    End If
                ElseIf Application.CountBlank(srg) = 3 Then
                
                If Not ddFound Is Nothing Then
                ddFound.EntireRow.Delete Shift:=xlShiftUp
            End If
        End If
        Next rrg
    Next arg
End Sub

And here is how the output looks,

Letters Log_2022.xlsm
EFGHIJKLMNOPQRSTUVWXYZAAABACADAEAFAGAHAIAJAKAL
2January1st2nd3rd4th5th6th7th8th9th10th11th12th13th14th15th16th17th18th19th20th21st22nd23rd24th25th26th27th28th29th30th31stTotal
3First Letter6000000000001300000000000000000019
4Second Letter00000000000000000000000000000000
5Third Letter00000000000000000000000000000000
6
7February1st2nd3rd4th5th6th7th8th9th10th11th12th13th14th15th16th17th18th19th20th21st22nd23rd24th25th26th27th28thTotal
8First Letter00000000000000000000000000000
9Second Letter00000000000000000000000000000
10Third Letter00000000000000000000000000000
11
12March1st2nd3rd4th5th6th7th8th9th10th11th12th13th14th15th16th17th18th19th20th21st22nd23rd24th25th26th27th28th29th30th31stTotal
13First Letter00000000000000000000000000000000
14Second Letter00000000000000000000000000000000
15Third Letter00000000000000000000000000000000
16
17April1st2nd3rd4th5th6th7th8th9th10th11th12th13th14th15th16th17th18th19th20th21st22nd23rd24th25th26th27th28th29th30thTotal
18First Letter0000000000000000000000000000000
19Second Letter0000000000000000000000000000000
20Third Letter0000000000000000000000000000000
21
22May1st2nd3rd4th5th6th7th8th9th10th11th12th13th14th15th16th17th18th19th20th21st22nd23rd24th25th26th27th28th29th30th31stTotal
23First Letter00000000000000000000000000000000
24Second Letter00000000000000000000000000000000
25Third Letter00000000000000000000000000000000
26
27June1st2nd3rd4th5th6th7th8th9th10th11th12th13th14th15th16th17th18th19th20th21st22nd23rd24th25th26th27th28th29th30thTotal
28First Letter0000000000000000000000000000000
29Second Letter0000000000000000000000000000000
30Third Letter0000000000000000000000000000000
31
32July1st2nd3rd4th5th6th7th8th9th10th11th12th13th14th15th16th17th18th19th20th21st22nd23rd24th25th26th27th28th29th30th31stTotal
33First Letter00000000000000000000000000000000
34Second Letter00000000000000000000000000000000
35Third Letter00000000000000000000000000000000
36
37August1st2nd3rd4th5th6th7th8th9th10th11th12th13th14th15th16th17th18th19th20th21st22nd23rd24th25th26th27th28th29th30th31stTotal
38First Letter00000000000000000000000000000000
39Second Letter00000000000000000000000000000000
40Third Letter00000000000000000000000000000000
41
42September1st2nd3rd4th5th6th7th8th9th10th11th12th13th14th15th16th17th18th19th20th21st22nd23rd24th25th26th27th28th29th30thTotal
43First Letter0000000000000000000000000000000
44Second Letter0000000000000000000000000000000
45Third Letter0000000000000000000000000000000
46
47October1st2nd3rd4th5th6th7th8th9th10th11th12th13th14th15th16th17th18th19th20th21st22nd23rd24th25th26th27th28th29th30th31stTotal
48First Letter00000000000000000000000000000000
49Second Letter00000000000000000000000000000000
50Third Letter00000000000000000000000000000000
51
52November1st2nd3rd4th5th6th7th8th9th10th11th12th13th14th15th16th17th18th19th20th21st22nd23rd24th25th26th27th28th29th30thTotal
53First Letter0000000000000000000000000000000
54Second Letter0000000000000000000000000000000
55Third Letter0000000000000000000000000000000
56
57December1st2nd3rd4th5th6th7th8th9th10th11th12th13th14th15th16th17th18th19th20th21st22nd23rd24th25th26th27th28th29th31th31stTotal
58First Letter00000000000000000000000000000000
59Second Letter00000000000000000000000000000000
60Third Letter00000000000000000000000000000000
Log
Cell Formulas
RangeFormula
AL58:AL60,AL48:AL50,AL38:AL40,AL33:AL35,AL23:AL25,AL13:AL15,AL3:AL5AL3=SUM(F3:AJ3)
AL8:AL10AL8=SUM(F8:AG8)
AL53:AL55,AL43:AL45,AL28:AL30,AL18:AL20AL18=SUM(F18:AI18)


So what I'm thinking, the reason is slow is it always loops through the entirety of all days every single time the code is run, how would I speed up the code/prevent it from looping through everything even if there is no data for i to add to the output?
 

Excel Facts

Square and cube roots
The =SQRT(25) is a square root. For a cube root, use =125^(1/3). For a fourth root, use =625^(1/4).
Sort by date Sort by votes
One of the main reasons that Vba is slow is the time taken to access the worksheet from VBa is a relatively long time.
To speed up vba the easiest way is to minimise the number of accesses to the worksheet. What is interesting is that the time taken to access a single cell on the worksheet in vba is almost identical as the time taken to access a large range if it is done in one action.

So instead of writing a loop which loops down a range checking one row at a time which will take a long time if you have got lots of rows it is much quicker to load the whole worksheet into a variant array ( one worksheet access), then check the values in that variant array and then do all the calculations in memory before using a second variant array to write all values back to the worksheet. This can be over a thousand times faster depending on what you are doing. Your code has got multiple loops which access the worksheet so it will be very slow. The good news is there is plenty of scope to speed it up. It is bit too complicated for me to get to do at the moment. This might be one way you can speed it up. Sorting out a different method depends on understanding what you are try to do which might be another way of speeding it up.



I have a simple rule for fast VBA: NEVER ACCESS THE WORKSHEET IN A LOOP.
 
Upvote 0
@Drawleeh I think we need some more info from you to properly assist you.

1) it appears that that you are working with one workbook called "Letters Log_2022.xlsm", that contains the code being discussed, and within that workbook is a sheet named 'Log' and another sheet, that the code being discussed is located in.

2) There is a second workbook that is opened called "H:\Branches\DACH067\Customs\Customs TRANSIT\Transit stats\Admin Output.xlsx" that has data copied to a sheet named 'Statistics'.

With those assumptions, I have came up with the following temp code:

VBA Code: 
Option Explicit

Private Sub Worksheet_Change(ByVal Target As Range)
'
    Const fRow  As Long = 2             ' FirstRow
'
    Dim crg As Range, irg   As Range
'
    Set crg = Columns("C:E").Resize(Rows.Count - fRow + 1).Offset(fRow - 1)
    Set irg = Intersect(crg, Target)
'
    If irg Is Nothing Then Exit Sub
'
    Dim ClmnAmnt            As Long, ClmnNmbr   As Long
    Dim DateRange           As Long
    Dim LastRow             As Long
    Dim RowCount            As Long
    Dim TypCount            As Long
    Dim arg                 As Range
    Dim rrg                 As Range, srg   As Range
    Dim arrDates            As Range
    Dim ddFound             As Range
    Dim dfCell              As Range            ' DateFormatCell
    Dim shtNames            As Range
    Dim lastAddrs           As String
    Dim srAddress           As String
    Dim AddrArr()           As Variant
    Dim ClmnDate()          As Variant
    Dim FrstLetter()        As Variant
    Dim wkb2                As Workbook             ' Destination_wkbk
    Dim sht2                As Worksheet
'
    LastRow = Sheets("Log").Range("A" & Sheets("Log").Rows.Count).End(xlUp).Row
'
    Set wkb2 = Workbooks.Open("H:\Branches\DACH067\Customs\Customs TRANSIT\Transit stats\Admin Output.xlsx")
    Set srg = Intersect(irg.EntireRow, crg)
    Set arrDates = Sheets("Log").Range("A60:A" & LastRow)
    Set shtNames = Sheets("Log").Range("B60:B" & LastRow)
'
    For Each arg In srg.Areas
        For Each rrg In arg.Rows
            srAddress = rrg.Address(0, 0)
'
            Set ddFound = Worksheets("Log").Columns("C").Find(srAddress, , xlFormulas, xlWhole)
'
            If Application.CountBlank(rrg) = 0 Then
                If ddFound Is Nothing Then
                    With Sheets("Log")
                        Set dfCell = .Cells(.Rows.Count, "A").End(xlUp).Offset(1)
'
                        dfCell.Value = Format(Date, "mm/dd/yyyy")
                        dfCell.Offset(, 1).Value = ActiveSheet.Name
                        dfCell.Offset(, 2).Value = srAddress
'
                        For RowCount = 2 To 57 Step 5
                            DateRange = WorksheetFunction.CountA(.Range("F" & RowCount & ":AJ" & RowCount))
'
                            For TypCount = 1 To 3
                                For ClmnNmbr = 1 To DateRange
                                    ReDim AddrArr(DateRange)
'
                                    AddrArr(ClmnNmbr) = .Cells(RowCount, ClmnNmbr + 5).Value
'
                                    ReDim FrstLetter(DateRange)
'
                                    FrstLetter(ClmnNmbr) = Application.CountIfs(arrDates, AddrArr(ClmnNmbr), shtNames, .Cells(RowCount + TypCount, 5).Value)
                                    Worksheets("Log").Cells(TypCount + RowCount, ClmnNmbr + 5).Value = Application.Transpose(FrstLetter(ClmnNmbr))
                                Next ClmnNmbr
                            Next TypCount
                        Next RowCount
'
                        Application.ScreenUpdating = False
'
                        ThisWorkbook.Sheets("Log").Range("E1:AL60").Copy
                        wkb2.Sheets("Statistics").Range("A1").PasteSpecial xlPasteValues
'
                        Application.CutCopyMode = False
'
                        wkb2.Close True
                        Application.ScreenUpdating = True
                    End With
                End If
            ElseIf Application.CountBlank(srg) = 3 Then
                If Not ddFound Is Nothing Then
                    ddFound.EntireRow.Delete Shift:=xlShiftUp
                End If
            End If
        Next rrg
    Next arg
End Sub

That code may run slightly faster if my assumptions are all correct. The purpose of the code submission is for you to verify that it still performs properly. If not, please let us know, if it does perform properly as your original submission does, we can then look further into speeding the code up. At this point, I am just trying to verify any changes made were correct, if so, we can then start the speed up.
 
Upvote 0
@johnnyL

All code that I had provided works, as @offthelip rightfully surmised the writing to cell process is taking up a lot of time, and I need to somehow figure out how to write to all cells at once. The part of the code that loops and writes to all of the dates as shown in the image I provided is this -

VBA Code: 
 With Sheets("Log")
                    Set dfCell = dws.Cells(dws.Rows.Count, dCol) _
                        .End(xlUp).Offset(1)
                        dfCell.Value = Format(Date, "mm/dd/yyyy")
                        dfCell.Offset(, 1).Value = ActiveSheet.Name
                        dfCell.Offset(, 2).Value = srAddress
                        
                        Dim arrDates As Range
                        Dim LastRow As Long
                        Dim DateRange As Long
                        Dim RowCount As Long
                        Dim ClmnAmnt As Long
                        Dim ClmnDate() As Variant
                        Dim AddrArr() As Variant
                        Dim ClmnNmbr As Long
                        Dim shtNames As Range
                        Dim TypCount As Long
                        Dim FrstLetter() As Variant
                        Dim SheetIdent As String
                        Dim lastAddrs As String
                        
                        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
                        
                        For RowCount = 2 To 57 Step 5
        
                                DateRange = WorksheetFunction.CountA(.Range("F" & RowCount & ":AJ" & RowCount))
                                    For TypCount = 1 To 3
                                        SheetIdent = .Cells(RowCount + TypCount, 5).Value2
                                            For ClmnNmbr = 1 To DateRange
                                            
                                                ReDim AddrArr(DateRange)
                                                AddrArr(ClmnNmbr) = .Cells(RowCount, ClmnNmbr + 5).Value2
                                                
                                                Set arrDates = .Range("A60:A" & LastRow)
                                                Set shtNames = .Range("B60:B" & LastRow)
                                                
                                                
                                                ReDim FrstLetter(DateRange)
                                                FrstLetter(ClmnNmbr) = Application.CountIfs(arrDates, AddrArr(ClmnNmbr), shtNames, SheetIdent)
                                                
                                                While RowCount = 2
                                                Worksheets("Log").Range("F3:AJ5").Value = Application.Transpose(FrstLetter())
                                                
                                            Next ClmnNmbr
                                     Next TypCount
                        Next RowCount
                        
                        End With

I need to figure out how to output all of the code from the
VBA Code: 
FrstLetter
array straight out into every day of the month. I think that's really the main issue here.
 
Upvote 0
It is not just writing to cells that take a long time is is also reading from cells.. There is another issue about your code, you NEVER do something in loop which stays the same within the loop. so a very quick look at your code you can improve it with these changes:
VBA Code: 
                        LastRow = .Range("A" & .Rows.Count).End(xlUp).Row  ' take this out of the loop saves doing this 11 times
                        Set arrDates = .Range("A60:A" & LastRow)  ' ditto
                        Set shtNames = .Range("B60:B" & LastRow)   'ditto
                        DateRange = WorksheetFunction.CountA(.Range("F" & RowCount & ":AJ" & RowCount)) ' ditto

                       For RowCount = 2 To 60 Step 5
'                            Select Case RowCount   ' no need for select case at all just step by 5
'                                Case 2, 7, 12, 17, 22, 27, 32, 37, 42, 47, 52, 57
                                LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
 '                               DateRange = WorksheetFunction.CountA(.Range("F" & RowCount & ":AJ" & RowCount))
                                    For TypCount = 1 To 3
                                        SheetIdent = .Cells(RowCount + TypCount, 5).Value
                                            For ClmnNmbr = 1 To DateRange
                                            
                                                ReDim AddrArr(DateRange)
                                                AddrArr(ClmnNmbr) = .Cells(RowCount, ClmnNmbr + 5).Value
                                                
 '                                               Set arrDates = .Range("A60:A" & LastRow)
  '                                              Set shtNames = .Range("B60:B" & LastRow)
                                                
                                                
                                                
                                                ReDim FrstLetter(DateRange)
                                                FrstLetter(ClmnNmbr) = Application.CountIfs(arrDates, AddrArr(ClmnNmbr), shtNames, SheetIdent)
                                                
                                                Worksheets("Log").Cells(TypCount + RowCount, ClmnNmbr + 5).Value = Application.Transpose(FrstLetter(ClmnNmbr))
                                                
                                                
                                            Next ClmnNmbr
                                     Next TypCount
'                                Case Else
'                            End Select
                        Next RowCount
 
Upvote 0
Just as an example of how to use variant arrays I have recoded this bit of code:
VBA Code: 
                                             Set arrdates = .Range("A60:A" & LastRow)   ' arrdates is a range this
                                              Set shtNames = .Range("B60:B" & LastRow)    ' shtnaes is a range
                                                
                                                ReDim FrstLetter(DateRange)
                                                FrstLetter(clmnNmbr) = Application.CountIfs(arrdates, AddrArr(clmnNmbr), shtNames, SheetIdent) ' this ac
to use variant arrays:
VBA Code: 
                                               arrdates = .Range("A60:B" & LastRow)   ' load both A and b column into a variant array arrdates is an array not a range
'                                              Set shtNames = .Range("B60:B" & LastRow)    ' shtnaes is a range
                                                
'                                                ReDim FrstLetter(DateRange)
'                                                FrstLetter(ClmnNmbr) = Application.CountIfs(arrDates, AddrArr(ClmnNmbr), shtNames, SheetIdent) ' this acces the two ranges on the workhseet slow
                                            'set up loop
                                              cntr = 0
                                             For i = 1 To UBound(arrdates)
                                               If arrdates(i, 1) = addr(clmnNmbr) And arrdates(i, 2) = SheetIdent Then
                                                cntr = cntr + 1
                                               End If
                                             Next i
                                             ReDim FrstLetter(DateRange)
                                              FrstLetter(clmnNmbr) = cntr
I think that what you should really be doing is loading the entire workhseet into memory and doing the whole calculation in memory, that is going to be the only way you can get it fast enough to operate sensibly on a worksheet change. Unfortunately I really don't understand what you are trying to do so I am limited in the help I can give..
 
Upvote 0
I forgot to comment out the 2nd occurence of this line in my post 5
VBA Code: 
LastRow = .Range("A" & .Rows.Count).End(xlUp).Row
 
Upvote 0
johnnyL said:
@Drawleeh I think we need some more info from you to properly assist you.

1) it appears that that you are working with one workbook called "Letters Log_2022.xlsm", that contains the code being discussed, and within that workbook is a sheet named 'Log' and another sheet, that the code being discussed is located in.

2) There is a second workbook that is opened called "H:\Branches\DACH067\Customs\Customs TRANSIT\Transit stats\Admin Output.xlsx" that has data copied to a sheet named 'Statistics'.



That code may run slightly faster if my assumptions are all correct. The purpose of the code submission is for you to verify that it still performs properly. If not, please let us know, if it does perform properly as your original submission does, we can then look further into speeding the code up. At this point, I am just trying to verify any changes made were correct, if so, we can then start the speed up.
Click to expand...

@Drawleeh Did you test the code I submitted to see if it still performs the changes properly? Many of the suggestions offered here have been done in that temp code I offered.
 
Upvote 0
You must log in or register to reply here.

Similar threads

L
  • Question Question
VBA Record when a new row of information is added to data set
Replies
0
Views
407
Lbdch
L
D
  • Question Question
Adjust code to account for variable entry
Replies
1
Views
440
Jeffrey Mahoney
Jeffrey Mahoney
D
  • Question Question
Speeding Up For Each Loop Populating Table Rows
2
Replies
14
Views
5K
baitmaster
baitmaster

Forum statistics

Threads
1,223,228
Messages
6,170,871
Members
452,363
Latest member
merico17

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