VBA Script (long) missing one condition....

[iRobert]

Hello,
This is a very long script I was able to "assemble". It seems to be working but it is missing a step.

Private Sub Worksheet_Change(ByVal Target As Range)
    Dim wbMas As Worksheet
    Dim strGBL As String
    Dim rngFind As Range
    Dim strAddress As String
    Dim strList As String
    On Error GoTo ErrHandler
    If Not Intersect(Range("A16"), Target) Is Nothing Then
        Application.EnableEvents = False
        Range("A16") = StrConv(Range("A16"), vbProperCase)
        Application.EnableEvents = True
    End If
    If Not Intersect(Range("A18"), Target) Is Nothing Then
        Application.EnableEvents = False
        Range("A18") = UCase(Range("A18"))
        Application.EnableEvents = True
        On Error Resume Next
        Set wbMas = Worksheets("Master")
        If wbMas Is Nothing Then Exit Sub
        On Error GoTo ErrHandler
        strGBL = Range("A18").Value
        If strGBL = "" Then Exit Sub
        With wbMas
            Set rngFind = .Range("I:I").Find(What:=strGBL, LookAt:=xlWhole)
            If Not rngFind Is Nothing Then
                strList = "GBL found:" & vbCrLf & rngFind.Offset(0, -8).Value & "   " & _
                    rngFind.Offset(0, -1).Value & "   " & strGBL
                strAddress = rngFind.Address
                Do
                    Set rngFind = .Range("I:I").FindNext(After:=rngFind)
                    If rngFind.Address = strAddress Then Exit Do
                    strList = strList & vbCrLf & rngFind.Offset(0, -2).Value & "   " & _
                        rngFind.Offset(0, -1).Value & "   " & strGBL
                Loop
                MsgBox strList, vbInformation
            End If
        End With
    End If
    ' **** Modified section ****
        If Range("J5") = "No" And Not Intersect(Range("A8,B16,D16,A18"), Target) Is Nothing Then
        Application.EnableEvents = False
        Select Case Left(Range("A18").Value, 4)
            Case ""
                Range("B16").Value = ""
             Case "WKAS"
                 Range("N17").Value = "Cit1"
                 Range("B16").Value = "City1"
            Case "UCFS"
                Range("N17").Value = "Cit2"
                Range("B16").Value = "City2"
            Case "UMNL"
                Range("N17").Value = "Cit3"
                Range("B16").Value = "City3"
            Case "UCNQ"
                Range("B16").Value = "Outbound"
            Case Else
                Range("B16").Value = "Inbound"
        End Select
        If Range("B16").Value = "Outbound" Then
            Range("F16").Value = Range("D16").Value
        End If

     End If
        Application.EnableEvents = True
      ' **** End of modified section ****
      If Range("J5") = "No" And Not Intersect(Range("A8,B16,A18,N17,E16"), Target) Is Nothing Then
        Application.EnableEvents = False
        Select Case Range("N17").Value
             Case ""
                  Range("E16").Value = ""
             Case "Cit1"
                  Range("E16").Value = "City1"
             Case "Cit2"
                  Range("E16").Value = "City2"
             Case "Cit3"
                  Range("E16").Value = "City3"
             Case "Cit4"
                  Range("E16").Value = "City4"
             Case "Cit5"
                  Range("E16").Value = "City5"
        End Select
      End If
      If Range("J5") = "No" And Not Intersect(Range("A8,B16,A18,N17,E16"), Target) Is Nothing Then
        Application.EnableEvents = False
        Select Case Range("B16").Value
             Case ""
                  Range("A23").Value = ""
             Case "Inbound"
                  Range("A23").Value = ""
             Case "Outbound"
                  Range("A23").Value = "Surcharge"
        End Select
      End If
         Application.EnableEvents = True
      ' ***** End Modified section ****
    Exit Sub
ErrHandler:
    MsgBox "Error with Invoice (Search GBL Duplicates) - error " & Err.Number & _
        " - " & Err.Description, vbExclamation
        
      ' ***** Adding "Surcharge"
    Const sAddress As String = "D16" ' Source Cell
    Const cAddress As String = "B16" ' Criteria Cell
    Const dAddress As String = "A23" ' Destination Cell
    Const fDate As String = "05/15/2021" ' First Date
    Const lDate As String = "09/30/2021" ' Last Date
         
    Dim sCell As Range: Set sCell = Range(sAddress)
    Dim cCell As Range: Set cCell = Range(cAddress)
    Dim dCell As Range: Set dCell = Range(dAddress)
        
    If Not Intersect(sCell, Target) Is Nothing _
            Or Not Intersect(cCell, Target) Is Nothing Then
        'Debug.Print "Intersecting..."
        On Error GoTo clearError
        Application.EnableEvents = False
        If VarType(sCell.Value) = vbDate Then
            'Debug.Print "It's a date."
            Dim cValue As Variant: cValue = CLng(sCell.Value)
            Dim fValue As Long: fValue = CLng(DateValue(fDate))
            Dim lValue As Long: lValue = CLng(DateValue(lDate))
            'Debug.Print cValue, fValue, lValue
            If cValue >= fValue And cValue <= lValue Then
              '  Debug.Print "In date range."
                Select Case CStr(cCell.Value)
                Case ""
                    dCell.Value = ""
                Case "Inbound"
                    dCell.Value = ""
                Case "Outbound"
                    dCell.Value = "Surcharge"
                Case Else
                    ' Neither "", "Inbound" or "Outbound"
                    dCell.Value = ""
                End Select
             Else
               ' Debug.Print "Not in date range."
                dCell.Value = ""
            End If
            
        Else
            'Debug.Print "Not a date"
            dCell.Value = ""
        End If
        
SafeExit:
        Application.EnableEvents = True
    Else
        'Debug.Print "Cell values not changed (No intersection)."
    End If

    Exit Sub
   
clearError:
    Debug.Print "Run-time error '" & Err.Number & "': " & Err.Description
    Resume SafeExit

End Sub

In the section:

               Case "Outbound"
                    dCell.Value = "Surcharge"

I need to add another another "result":
when dCell.Value = "Surcharge"
Cell C23 must have the value of I1 (C23=I1)
Cell D23 must have the value of 1 (D23=1)

If anyone is willing to be challenged, I would appreciate it.

Thanks
R

 

[johnnyL]

Lets's try this in an alternative way, Replace the following:

                Case "Outbound"
                    dCell.Value = "Surcharge"
                    Range("C23").Value = Range("I1").Value
                    Range("D23").Value = 1

With:

                Case "Outbound"
                    Debug.Print "Now executing Surcharge-Outbound"
                    dCell.Value = "Surcharge"
                    Range("C23").Value = Range("I1").Value
                    Range("D23").Value = 1

See if that prints to the Debug window when you run the script.

 

[iRobert]

Lets's try this in an alternative way, Replace the following:

                Case "Outbound"
                    dCell.Value = "Surcharge"
                    Range("C23").Value = Range("I1").Value
                    Range("D23").Value = 1

With:

                Case "Outbound"
                    Debug.Print "Now executing Surcharge-Outbound"
                    dCell.Value = "Surcharge"
                    Range("C23").Value = Range("I1").Value
                    Range("D23").Value = 1

See if that prints to the Debug window when you run the script.

I see nothing.....
I have no idea....

R

 

[johnnyL]

If you didn't see anything in the debug window, well that means that part of the code is not being executed in your error handler. I think that is what @Michael M was trying to determine.

 

[iRobert]

I gave up.
I changed the approach and I am using a formula in a designated line where I removed the dropdown menu that prevented formulas (that is why I needed this script).
R