Macro slows down with each use

[mumps]

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.

 

[Peter_SSs]

Seeing the code may possibly turn up a suggestion.

 

[mumps]

Hello Peter. This is the code. Thank you.

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]

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]

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:

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.

 

[mumps]

Cross post: https://www.excelforum.com/excel-programming-vba-macros/1287696-macro-slows-down-with-each-use.html