Macro slows down with each use

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,589
I have a Worksheet_SelectionChange event that runs very quickly the first time it is triggered after the file is opened. Selecting a cell brings up a calendar and upon selecting a date in the calendar, some data is processed. Each successive time the macro is triggered, it slows down even though the amount of data processed is the same. If I close the file and re-open it, the first time the macro is triggered, it runs quickly and then proceeds to slow down again with each successive run. Does anyone have any suggestions as to what could be causing this problem? Many thanks.
 

Some videos you may like

Excel Facts

Copy formula down without changing references
If you have =SUM(F2:F49) in F50; type Alt+' in F51 to copy =SUM(F2:F49) to F51, leaving the formula in edit mode. Change SUM to COUNT.

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
46,310
Office Version
  1. 365
Platform
  1. Windows
Seeing the code may possibly turn up a suggestion.
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,589
Hello Peter. This is the code. Thank you.
Code:
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    ThisWorkbook.NoEvents = True
    If Intersect(Target, Range("K7")) Is Nothing Then Exit Sub
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
    End With
    CalendarFrm.Show
    Dim rowCount As Long, srcWS As Worksheet, Rng As Range, lastRow As Long, x As Long, y As Long, z As Long
    Dim att As Long, take As Long, discuss As Long, dir As Long, com As Long, dsi As Long
    lastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    att = Range("A:A").Find("MEETING ATTENDEES:").Row
    take = Range("A:A").Find("TAKE AWAY / GUIDANCE:").Row
    discuss = Range("A:A").Find("DISCUSSION:").Row
    dir = Range("A:A").Find("DIRECTORATE HIGHLIGHTS:").Row
    com = Range("A:A").Find("Communications and Major Events").Row
    dsi = Range("A:A").Find("Directorate of Systems Integration (DSI)").Row
    If Range("A" & dsi + 1) <> "" Then Rows(dsi + 1).ClearContents
    If Range("A" & com + 1) <> "" Then Rows(com + 1).ClearContents
    If Range("A" & discuss + 1) <> "" Then Rows(discuss + 1 & ":" & dir - 2).EntireRow.Delete
    If Range("A" & take + 1) <> "" Then Rows(take + 1 & ":" & discuss - 2).EntireRow.Delete
    If Range("A" & att + 1) <> "" Then Rows(att + 1 & ":" & take - 2).EntireRow.Delete
    Range("M3:N" & lastRow).ClearContents
    Range("D9").ClearContents
    Range("K3").Select
    x = 1
    y = att + 1
    z = att
    On Error Resume Next
    Set srcWS = Sheets(Format(Target, "mm-dd-yyyy"))
    On Error GoTo 0
    If Not srcWS Is Nothing Then
        Range("D9") = Range("K7")
        With srcWS.Cells(2, 1)
            .AutoFilter Field:=3, Criteria1:="<>"
        End With
        rowCount = [subtotal(103,A:A)] - 2
        srcWS.Range("A3", srcWS.Range("A" & srcWS.Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
        Range("M3").PasteSpecial xlPasteValues
        srcWS.Range("C3", srcWS.Range("C" & srcWS.Rows.Count).End(xlUp)).SpecialCells(xlCellTypeVisible).Copy
        Range("N3").PasteSpecial xlPasteValues
        lastRow = Range("M" & Rows.Count).End(xlUp).Row
        For Each Rng In Range("M3:M" & lastRow)
            Rng.Copy
            Cells(y, x).Insert
            With Cells(y, x)
                .Value = ChrW(&H25A0) & " " & Cells(y, x)
                .WrapText = False
            End With
            y = y + 1
            If y > z + WorksheetFunction.RoundUp(rowCount / 3, 0) Then
                y = 16
                x = x + 3
            End If
        Next Rng
        
        take = Range("A:A").Find("TAKE AWAY / GUIDANCE:").Row
        With srcWS.Cells(2, 1)
            .AutoFilter Field:=4, Criteria1:="<>"
        End With
        lastRow = srcWS.Range("D" & srcWS.Rows.Count).End(xlUp).Row
        x = 1
        For Each Rng In srcWS.Range("D3:D" & lastRow).SpecialCells(xlCellTypeVisible)
            Dim val As String
            val = Rng.Value
            Cells(take + 1, x).Insert
            With Cells(take + 1, x)
                .Value = ChrW(&H25A0) & " " & val
                .Font.Bold = False
            End With
            take = take + 1
        Next Rng
        
        srcWS.Range("C2").AutoFilter
        If srcWS.Range("F7") <> "" Then
            discuss = Range("A:A").Find("DISCUSSION:").Row
            val = srcWS.Range("F7").Value
            Cells(discuss + 1, x).Insert
            With Cells(discuss + 1, x)
                .Value = ChrW(&H25A0) & " " & val
                .WrapText = False
                .Font.Bold = False
            End With
        End If
        If srcWS.Range("F8") <> "" Then
            discuss = discuss + 1
            val = srcWS.Range("F8").Value
            Cells(discuss, x).Insert
            With Cells(discuss, x)
                .Value = ChrW(&H25A0) & " " & val
                .WrapText = False
                .Font.Bold = False
            End With
        End If
        srcWS.Range("C2").AutoFilter
        
        If srcWS.Range("F12") <> "" Then
            com = Range("A:A").Find("Communications and Major Events").Row
            val = srcWS.Range("F12").Value
            With Cells(com + 1, x)
                .Value = ChrW(&H25A0) & " " & val
                .WrapText = False
                .Font.Bold = False
            End With
        End If
        
        If srcWS.Range("F10") <> "" Then
            dsi = Range("A:A").Find("Directorate of Systems Integration (DSI)").Row
            val = srcWS.Range("F10").Value
            With Cells(dsi + 1, x)
                .Value = ChrW(&H25A0) & " " & val
                .WrapText = False
                .Font.Bold = False
            End With
        End If
    Else
        MsgBox ("A worksheet with the date " & Target & " does not exist.  Please select a different date.")
        Target.ClearContents
        ActiveSheet.Shapes.Range(Array("Rounded Rectangle 3")).Visible = False
        ActiveSheet.Shapes.Range(Array("Rounded Rectangle 5")).Visible = False
        Range("K3").Select
    End If
    If Range("A16") <> "" Then
        ActiveSheet.Shapes.Range(Array("Rounded Rectangle 3")).Visible = True
        ActiveSheet.Shapes.Range(Array("Rounded Rectangle 5")).Visible = True
    Else
        ActiveSheet.Shapes.Range(Array("Rounded Rectangle 3")).Visible = False
        ActiveSheet.Shapes.Range(Array("Rounded Rectangle 5")).Visible = False
    End If
    ThisWorkbook.NoEvents = False
    With Application
        .CutCopyMode = False
        .ScreenUpdating = True
        .EnableEvents = True
    End With
End Sub
 

Peter_SSs

MrExcel MVP, Moderator
Joined
May 28, 2005
Messages
46,310
Office Version
  1. 365
Platform
  1. Windows
Hello Peter. This is the code. Thank you.
Thanks. Nothing is jumping out at me and obviously no way to test so I don't think that I can offer anything useful.
I presume that you have tried inserting a break point and stepping through the code?
 

mumps

Well-known Member
Joined
Apr 11, 2012
Messages
9,589
Thanks, Peter for your quick response. I have tried that and it makes no difference. The slowest part of the code seems to be the following:
Code:
For Each Rng In Range("M3:M" & lastRow)
            Rng.Copy
            Cells(y, x).Insert
            With Cells(y, x)
                .Value = ChrW(&H25A0) & " " & Cells(y, x)
                .WrapText = False
            End With
            y = y + 1
            If y > z + WorksheetFunction.RoundUp(rowCount / 3, 0) Then
                y = 16
                x = x + 3
            End If
        Next Rng
I inserted a break point at the beginning and end of this section of code and ran the macro several times on the same data. The loop has only the same 10 values to loop through each time but it seems to slow down after each run. I tried to think of an different way to code this section to achieve the same result but I couldn't think of a way. Perhaps if this part of the code could be modified, it would fix the problem. I should mention that I have two other events in the code module for ThisWorkbook. Since "Application.EnableEvents=False" doesn't disable these two events, I had to use the Boolean variable to exit those two events so they wouldn't run through completely and slow the macro even further.
 

Watch MrExcel Video

Forum statistics

Threads
1,109,400
Messages
5,528,511
Members
409,821
Latest member
decibelpilot

This Week's Hot Topics

  • Change military grades into rank
    Afternoon all Need help with formula that will change military rank (i.e. 1, 2, 3 into Amn, A1C, SrA). Running IF formula that does not work...
  • VBA COUNTIF SOLUTION
    Hi The following are the errors spread across the several columns from E to Q ie. 13 columns across several sheets with more than 500 rows per...
  • INSERT ROW WITH SPECIFIS TEXT IN A COLUMN
    Hi All! How can identify that that the row to be inserted has to be inserted before 1st row with specific text in column F. If I record the...
  • Auto-Create a monthly Sign in sheet for preschool students
    The image below is what each page looks like. Above is space for the "Child Name" "Month" "Class" School days are obviously Monday-Friday but...
  • VBA vlookup multiple results
    Hi folks, Hopefully someone out there can help. I have a list to vlookup which works (ish). the lookup only picks up the first instance of the...
  • Extract values for earliest/latest times
    I am trying to put together a formula to get the earliest start time, the latest end time from column A for each person in Column B-F without the...
Top