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

I

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

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
Sort by date Sort by votes
VBA Code: 
    Case "Outbound"
        dCell.Value = "Surcharge"
        Range("C23").Value = Range("I1").Value
        Range("D23").Value = 1
 
Upvote 0
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
 
Upvote 0
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!!
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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.
 
Upvote 0
F8 stops at:
Code: 
    Exit Sub
ErrHandler:
    MsgBox "Error with Invoice (Search GBL Duplicates) - error " & Err.Number & _
        " - " & Err.Description, vbExclamation

R
 
Upvote 0
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
 
Upvote 0
You must log in or register to reply here.

Similar threads

excelbytes
  • Solved
Looping Procedure In VBA Code
2 3
Replies
24
Views
455
excelbytes
excelbytes
S
  • Question Question
VBA Script to merge cells based on cell value
Replies
1
Views
138
Joe4
Joe4
E
  • Question Question
Copy Cell as Hyperlink to another cell
Replies
1
Views
241
eli_m
E
F
  • Question Question
conditionally Shrink to fit or Wrap text with certain font size using byval
Replies
1
Views
132
RoryA
RoryA
J
  • Question Question
Combining VBA Codes
Replies
4
Views
274
DanteAmor
DanteAmor

Forum statistics

Threads
1,223,909
Messages
6,175,314
Members
452,634
Latest member
cpostell

Share this page

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
Back
Top