Problems with speed of code

[Pauljj]

Morning,

I have written some code, which does work but I don't think it's the right code for what I am trying to achieve. I broke the run of the code after it had been running for 15 minutes

There's 2 parts to this

On sheet 'freight detail' there are a selection of different drop down options (determined by data validation) The user, for example has a drop down in cell C4, this is a list of months (Jan to Dec)

(D4 is a formula pulling the month number)

On sheet 'Freight data' is a huge data set of about 700,000 rows. On this sheet in column T, is a booking date. If the month selected in C4 equals the month in T5 (for example) then I want AO5 to equal 1, if it doesn't then it should be blank

If the user deletes the month in cell C4 then I need to assign 1 to every cell in AO (this is because 1 resembles a match on the month, if there is no month selected in C4 then every call is a match

The problem is the process of checking off every single cell is taking way too long......is there a better way ?

Sub bkgmonth()

Application.ScreenUpdating = False

Dim monthnum As Integer
Dim monthrec As Integer
Dim r As Range

On Error Resume Next

monthnum = Sheets("Freight Detail").Range("D4")

endrow = Cells(Rows.Count, 1).End(xlUp).Row

Set r = Range(Cells(2, 41), Cells(endrow, 41))

If Sheets("Freight Detail").Range("c4") = "" Then

For Each cell In r

    If cell.Value = 0 Then
    
        cell.Value = cell.Value + 1
    End If
    
Next

End If

Sheets("Freight Data").Activate




Range(Cells(2, 41), Cells(endrow, 41)).ClearContents

For d = 2 To endrow


monthrec = Month(Cells(d, 20))


    If monthrec = monthnum Then
    
    Cells(d, 41) = 1
    
    End If
    
Next d
    
Sheets("Freight Detail").Activate
    
    
Application.ScreenUpdating = True

End Sub

 

[GWteB]

If all cells in column T involved are consistently formatted as date, the code below should do what you described.

Public Sub pauljj()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim oWsInput    As Worksheet
    Dim oWsData     As Worksheet
    Dim c           As Range
    Dim r           As Range
    Dim arrT        As Variant
    Dim arrAO       As Variant
    Dim MonthNum    As Long
    Dim EndRow      As Long
    Dim i           As Long

    Set oWsInput = ThisWorkbook.Sheets("freight detail")
    Set oWsData = ThisWorkbook.Sheets("freight data")

    MonthNum = oWsInput.Range("C4").Value

    With oWsData
        EndRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set c = .Range(.Cells(2, "T"), .Cells(EndRow, "T"))
        Set r = .Range(.Cells(2, "AO"), .Cells(EndRow, "AO"))
    End With

    If Len(MonthNum) = 0 Then
        r.Value = 1
    Else
        arrT = c.Value
        arrAO = r.Value
        For i = LBound(arrT, 1) To UBound(arrT, 1)
            If MonthNum = Month(arrT(i, 1)) Then
                arrAO(i, 1) = 1
            Else
                arrAO(i, 1) = vbNullString
            End If
        Next i
        r.Value = arrAO
    End If

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

 

[Pauljj]

If all cells in column T involved are consistently formatted as date, the code below should do what you described.

Public Sub pauljj()

    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual

    Dim oWsInput    As Worksheet
    Dim oWsData     As Worksheet
    Dim c           As Range
    Dim r           As Range
    Dim arrT        As Variant
    Dim arrAO       As Variant
    Dim MonthNum    As Long
    Dim EndRow      As Long
    Dim i           As Long

    Set oWsInput = ThisWorkbook.Sheets("freight detail")
    Set oWsData = ThisWorkbook.Sheets("freight data")

    MonthNum = oWsInput.Range("C4").Value

    With oWsData
        EndRow = .Cells(.Rows.Count, "A").End(xlUp).Row
        Set c = .Range(.Cells(2, "T"), .Cells(EndRow, "T"))
        Set r = .Range(.Cells(2, "AO"), .Cells(EndRow, "AO"))
    End With

    If Len(MonthNum) = 0 Then
        r.Value = 1
    Else
        arrT = c.Value
        arrAO = r.Value
        For i = LBound(arrT, 1) To UBound(arrT, 1)
            If MonthNum = Month(arrT(i, 1)) Then
                arrAO(i, 1) = 1
            Else
                arrAO(i, 1) = vbNullString
            End If
        Next i
        r.Value = arrAO
    End If

    Application.Calculation = xlCalculationAutomatic
    Application.ScreenUpdating = True
End Sub

Brilliant, thanks very much, works perfectly, just working my way through the Lbound and Ubound code as I'm unfamiliar with this

 

[GWteB]

You are welcome and thanks for letting me know.
This code uses the Array memory type. Its boundaries are determined the moment the Array is filled from the worksheet (at least in this case, boundaries can also be predefined). LBound and UBound functions read the current boundaries. Attempts to read the memory outside these boundaries will result in run-time errors. Using the Array memory type is recommended over frequent separate access to worksheet ranges, as the latter is inherently very slow.