Optimize Code, Running Slowly

Hello,

The attached VBA project is used to enter customer orders for flats of annual flowers. In the "Flower Order Entry" tab, the user selects varieties of flowers from drop-down menus in Column T under "Common Name." The colors available for each variety are then highlighted green in columns U thru AR based on the saved colors for each variety in the "Data" tab. The user then enters how many flats of each color are to be ordered. Finally, the code compiles a summary of the order in columns L thru O.

My code is providing the intended result but after about 5 varieties are entered, the code runs very slowly. There are several nested loops that are used to compile the order summary that, I imagine, could be optimized but I am not sure how. I am looking for suggestions and guidance on how to optimize this code to run more efficiently. I imagine that I am recalculating variables a lot more often than I need to but I am not familiar enough with using public variables to use them confidently. I have been using VBA off and on for a few years now but and I have other versions of this project but they are not as dynamic as I need them to be. My relevant code is below:

Public Functions lrFind and cntUnique are used to evaluate the saved varieties and colors in the "Data" tab to define and resize various ranges and compile a list of unique colors available in the "Flower Order Entry" tab:

Public Function lrFind(rngRowTarget As Range) As Long

'Finds the last row used in a given 2-D range, given range must start in Row 1
'Intended to make adding new varieiteis and colors dynamic

    Dim celFind As Range
    Dim cols As Long
    Dim i As Double
    
        cols = rngRowTarget.Columns.Count
        i = 1

    Dim arrRowFind()
        ReDim arrRowFind(cols)
        
    With rngRowTarget
        
        For i = 1 To cols
            arrRowFind(i) = .Cells(Rows.Count, i).End(xlUp).row
        Next i
        
    End With
    
    lrFind = Application.WorksheetFunction.Max(arrRowFind)

End Function

Public Function cntUnique(rngCountTarget As Range) As Long

'Counts unique values contained within a given range
'Intended to make adding new varieties and colors dynamic

    Dim dict
    Dim cell As Range
    
        Set dict = CreateObject("Scripting.Dictionary")
        
        For Each cell In rngCountTarget.Cells
            If Not dict.Exists(cell.Value) Then
                dict.Add cell.Value, 0
            End If
        Next
        
    cntUnique = dict.Count - 1
    
End Function

Worksheet_Change Procedure every time the user enters or changes a value in the Order Entry table:

Private Sub Worksheet_Change(ByVal Target As Range)
    
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    
    Dim Wb As Workbook
    Dim wsData As Worksheet
    
    Dim rngKeyCommon As Range
    Dim rngKeyOrder As Range
    Dim rngOrderColors As Range
    Dim rowActive As Long
    Dim rngActive As Range
    Dim strActive As String
    
    Dim rngDataCommon As Range
    Dim rngDataLatin As Range
    Dim rngDataColors As Range
    Dim rngDataMatchColor As Range
    Dim cntDataVar As Long
    Dim lrData As Long
    Dim cntDataColors As Long
    Dim colData As Long
    Dim lrColorCol As Long
    
    Dim celName As Range
    Dim celColor As Range
    
        Set Wb = ThisWorkbook
        Set wsData = Wb.Worksheets("Data")
        
    With wsData
    
        Set rngDataLatin = .Range("lstrng_LatinNames")
        Set rngDataCommon = .Range("lstrng_CommonNames")
        
        cntDataVar = rngDataCommon.Columns.Count
        lrData = lrFind(rngDataLatin)
        
        Set rngDataColors = .Range("$A$3", .Cells(lrData, cntDataVar))
        
        cntDataColors = cntUnique(rngDataColors)
        
    End With
    
    With Me
    
        Set rngKeyCommon = .Range("$T$11", .Cells(10 + cntDataVar, 20))
        Set rngKeyOrder = .Range("$U$11", .Cells(10 + cntDataVar, 20 + cntDataColors))
        Set rngOrderColors = .Range("$U$10", .Cells(10, 20 + cntDataColors))
        
    End With
    
    On Error GoTo Quit:
    
    If Not Intersect(rngKeyCommon, Me.Range(Target.Address)) Is Nothing Then
    
        rowActive = Target.row
        strActive = Target.Value
        
        With Me
        
            Set rngActive = .Range(.Cells(rowActive, 21), .Cells(rowActive, 21 + cntDataColors))
            
            rngActive.ClearContents
            rngActive.Interior.ColorIndex = 0
            rngActive.Columns.EntireColumn.Hidden = False
            
            .Range("$S" & rowActive).ClearContents
            
        End With
        
        With wsData
            
            For Each celName In rngDataCommon
                If celName.Value = strActive Then
                    colData = celName.Column
                    lrColorCol = .Cells(Rows.Count, colData).End(xlUp).row
                End If
            Next celName
            
            Set rngDataMatchColor = .Range(.Cells(3, colData), .Cells(lrColorCol, colData))
            
        End With
        
        With Me
        
            .Cells(rowActive, 19) = rngDataLatin(1, colData)
        
            For Each celColor In rngOrderColors
                If Application.WorksheetFunction.CountIf(rngDataMatchColor, celColor.Value) = 0 Then
                    If chkbox_DisableHideCols.Value = False Then
                        celColor.EntireColumn.Hidden = True
                    ElseIf chkbox_DisableHideCols.Value = True Then
                        celColor.EntireColumn.Hidden = False
                    End If
                Else
                    celColor.EntireColumn.Hidden = False
                    With .Cells(rowActive, celColor.Column).Interior
                        .ThemeColor = xlThemeColorAccent6
                        .TintAndShade = 0.399975585192419
                    End With
                End If
            Next celColor
            
        End With
        
    End If
        
    If Not Intersect(rngKeyOrder, Me.Range(Target.Address)) Is Nothing Then
    
        Call SummaryUpdate
        
    End If
              
Quit:
                       
    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
        
End Sub

Module 1 Sub to Update the Order Summary in Columns L thru O:

Public Sub SummaryUpdate()

'Compiles and summarizes the order in columns L thru O
'Runs every time the user enters or changes a value in the Order Entry table

    Dim Wb As Workbook
    Dim wsOrderEntry As Worksheet
    Dim wsData As Worksheet
    
    Dim rngLatinNames As Range
    Dim rngSavedColors As Range
    Dim lrData
    Dim cntVar As Long
    Dim cntColors As Long
    Dim i As Long
    Dim row As Long
    Dim col As Long
    Dim celName As Range
    Dim celFlats As Range
    
    Dim cntOrderRows As Long
    Dim sumFlats As Single
    Dim cntSumVar As Long
    Dim rngSummary As Range
    
    Dim rngOrder As Range
    Dim rngOrderRow As Range
    Dim rngNames As Range
    Dim rngCntOrderRows As Range
    
    Set Wb = ThisWorkbook
    Set wsOrderEntry = Wb.Worksheets("Flower Order Entry")
    Set wsData = Wb.Worksheets("Data")
    
    With wsOrderEntry
    
        Dim lrClearSum As Long
            lrClearSum = .Cells(Rows.Count, 15).End(xlUp).row
            
        If lrClearSum <= 6 Then
            lrClearSum = 7
        End If
        
        .Range("$O$4").ClearContents
        .Range("$O$5").ClearContents
        .Range("$L$7", .Cells(lrClearSum, 15)).ClearContents
    
    End With
    
    With wsData
    
        Set rngLatinNames = .Range("lstrng_LatinNames")
        
        cntVar = rngLatinNames.Columns.Count
        lrData = lrFind(rngLatinNames)
        
        Set rngSavedColors = .Range("$A$3", .Cells(lrData, cntVar))
        
        cntColors = cntUnique(rngSavedColors)
        
    End With
    
    With wsOrderEntry
    
        Set rngCntOrderRows = .Range("$T$11", .Cells(10 + cntVar, 20))
        
        cntOrderRows = Application.WorksheetFunction.CountA(rngCntOrderRows)
        
        Set rngNames = .Range("$T$11", .Cells(10 + cntOrderRows, 20))
        Set rngOrder = .Range("$U$11", .Cells(10 + cntOrderRows, 20 + cntColors))
        
        cntSumVar = Application.WorksheetFunction.CountA(rngOrder)
        sumFlats = Application.WorksheetFunction.Sum(rngOrder)
        
        .Range("$O$4").Value = cntSumVar
        .Range("$O$5").Value = sumFlats
        .Range("$M$3").Value = .Range("$T$3").Value
        .Range("$M$4").Value = .Range("$T$4").Value
        .Range("$M$5").Value = .Range("$T$5").Value
        
        Set rngSummary = .Range("$L$7", .Cells(7 + cntSumVar, 15))
        
        i = 1
        
        For Each celName In rngNames
        
            row = celName.row
            
            Set rngOrderRow = .Range(.Cells(row, 21), .Cells(row, 20 + cntColors))
            
                rngSummary(i, 1) = .Cells(row, 19)
                rngSummary(i, 2) = .Cells(row, 20)
                
                For Each celFlats In rngOrderRow
                
                    If Not IsEmpty(celFlats) Then
                    
                        col = celFlats.Column
                        
                        rngSummary(i, 3) = .Cells(10, col)
                        rngSummary(i, 4) = celFlats
                        
                        i = i + 1
                        
                    End If
                
                Next celFlats
            Next celName
               
    End With

Quit:

End Sub

Thank you all, in advance, for any help.