0
votes

I have a worksheet change event that, when 3 adjacent cells are filled in columns C,D and E it is documented in a different sheet with the date as well as the sheet that where the cells have been filled in.

Then every occurrence of date data is summed up and plotted on a calendar essentially showing how many entries have occurred for everyday of the year.

The issue is, is that the code loops through all days of the year which makes it incredibly slow, is there any way to make adjustments so it doesn't loop through everything or at least to speed up the process?

This is the code for the loops in question:

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

    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
For RowCount = 2 To 57 Step 5, set LastRow outside your loopcybernetic.nomad
For speed, you can turn off Application.ScreenUpdating while the macro is running, set to False at the start of the loop and True at the end. Also, since you're making changes to the sheet, you can temporarily disable sheet recalculations as well with Application.Calculation = xlCalculationManual. Don't forget to set it back to auto (xlCalculationAutomatic). These two things should improve the execution speed by a large amount.Toddleson