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

iRobert

New Member
Joined
May 15, 2019
Messages
28
Hello,
This is a very long script I was able to "assemble". It seems to be working but it is missing a step.
Code:
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:
Code:
               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
 

Excel Facts

Save Often
If you start asking yourself if now is a good time to save your Excel workbook, the answer is Yes

johnnyL

Well-known Member
Joined
Nov 7, 2011
Messages
1,459
Office Version
  1. 2013
  2. 2007
Platform
  1. Windows
VBA Code:
    Case "Outbound"
        dCell.Value = "Surcharge"
        Range("C23").Value = Range("I1").Value
        Range("D23").Value = 1
 

iRobert

New Member
Joined
May 15, 2019
Messages
28
This would be the final code but I cannot make it work:
Code:
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 "ABCD"
                 Range("N17").Value = "Firm1"
                 Range("B16").Value = "Outbound"
            Case "EFGH"
                Range("N17").Value = "Firm2"
                Range("B16").Value = "Outbound"
            Case "IJKL"
                Range("N17").Value = "Firm3"
                Range("B16").Value = "Outbound"
            Case "MNOP"
                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 "Firm1"
                  Range("E16").Value = "City1"
             Case "Firm2"
                  Range("E16").Value = "City2"
             Case "Firm3"
                  Range("E16").Value = "City3"
             Case "Firm4"
                  Range("E16").Value = "City4"
             Case "Firm5"
                  Range("E16").Value = "City5"
        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"
                    Range("C23").Value = Range("I1").Value
                    Range("D23").Value = 1
                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

I would be grateful if someone can review it and help me......

R
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
21,007
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows
With the length of the code, this "but I cannot make it work:" doesn't help us !
Do you get an error ?
Do you get an incorrect result?
Does the code not run ??
We need more information!!
 

iRobert

New Member
Joined
May 15, 2019
Messages
28

ADVERTISEMENT

The Surcharge Part of the script does not work.
All the rest does
I see no error, just it does not fill the cells.

Thanks
R
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
21,007
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows
Do you mean this part
VBA Code:
Case "Outbound"
                    dCell.Value = "Surcharge"
                    Range("C23").Value = Range("I1").Value
                    Range("D23").Value = 1
Put a break point in the code at this line
VBA Code:
Select Case CStr(cCell.Value)
then use F8 to step through one line at a time to see if it either steps over it.
Is "Outbound" spelt with a capital "O' in the worksheet ??
Also, check to make sure "Outbound" doesn't have any leading / trailing spaces
 

iRobert

New Member
Joined
May 15, 2019
Messages
28

ADVERTISEMENT

Outbound is in a dropdown menu with only 2 choices: Outbound, Inbound
It is predefined.
R
 

Michael M

Well-known Member
Joined
Oct 27, 2005
Messages
21,007
Office Version
  1. 2016
  2. 2013
  3. 2007
Platform
  1. Windows
did you do this ??
Put a break point in the code at this line
VBA Code:
Select Case CStr(cCell.Value)
then use F8 to step through one line at a time to see if it either steps over it.
 

iRobert

New Member
Joined
May 15, 2019
Messages
28
F8 stops at:
Code:
    Exit Sub
ErrHandler:
    MsgBox "Error with Invoice (Search GBL Duplicates) - error " & Err.Number & _
        " - " & Err.Description, vbExclamation

R
 

iRobert

New Member
Joined
May 15, 2019
Messages
28
This works perfectly in a simple xlsm file:
Code:
Private Sub Worksheet_Change(ByVal Target As Range)
    
    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 = ""
                    Range("C23").Value = ""
                    Range("D23").Value = ""
                Case "Inbound"
                    dCell.Value = ""
                    Range("C23").Value = ""
                    Range("D23").Value = ""
                Case "Outbound"
                    dCell.Value = "Surcharge"
                    Range("C23").Value = Range("I1").Value
                    Range("D23").Value = 1
                Case Else
                    ' Neither "", "Inbound" or "Outbound"
                    dCell.Value = ""
                    Range("C23").Value = ""
                    Range("D23").Value = ""
                End Select
            Else
                Debug.Print "Not in date range."
                dCell.Value = ""
                Range("C23").Value = ""
                Range("D23").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
 

Forum statistics

Threads
1,144,235
Messages
5,723,161
Members
422,479
Latest member
Mr_Confused

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top