Looping Procedure In VBA Code

excelbytes

excelbytes

Active Member
Joined
Dec 11, 2014
Messages
291
Office Version
  1. 365
Platform
  1. Windows
I have several procedures in the Worksheet_Change procedure. The first three work fine. The last one highlighted in red at the end below is where I have an issue. I think I need to implement a looping procedure but don't know how to do that properly. What I want to occur is as follows:

Cells B15:B50 can have either an "H" or "K" in it. Any number of these cells can have either. So cell B15 can be "K", B16 can be "H", B17 can be "H", B18 can be "K", etc.

If an "H" is in any of the cells in B15:B50, the corresponding cell in column H needs to have a drop down list based on this:

VBA Code: 
      Set rngLookup = Worksheets("HYUNDAI").Range("P2:R107")
  
      Application.EnableEvents = False
      
      Target.Value = Application.VLookup(Target.Value, rngLookup, 2, False)
    
      Application.EnableEvents = True

If a "K" is in any of the cells in B15:B50, the corresponding cell in column H needs to have a drop down list based on this:

VBA Code: 
      Set rngLookup = Worksheets("KIA").Range("P2:R75")
  
      Application.EnableEvents = False
      
      Target.Value = Application.VLookup(Target.Value, rngLookup, 2, False)
    
      Application.EnableEvents = True

So H15 could have a different drop down list than H16, than H17, etc.

Here is the complete code:

VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)
Dim rngLookup As Range

    If Not Intersect(Target, Range("L15:L50")) Is Nothing Then
        
      If Len(Trim(Target.Value)) = 0 Then
        Exit Sub
      End If
      
      Set rngLookup = Worksheets("FORM DETAILS").Range("E4:G25")
  
      Application.EnableEvents = False
      
      Target.Value = Application.VLookup(Target.Value, rngLookup, 2, False)
    
      Application.EnableEvents = True

    End If


    If Not Intersect(Target, Range("P15:P50")) Is Nothing Then
        
      If Len(Trim(Target.Value)) = 0 Then
        Exit Sub
      End If
      
      Set rngLookup = Worksheets("FORM DETAILS").Range("H4:J5")

      Application.EnableEvents = False
      
      Target.Value = Application.VLookup(Target.Value, rngLookup, 2, False)
    
      Application.EnableEvents = True

    End If


    If Not Intersect(Target, Range("M15:M50")) Is Nothing Then
        
      If Len(Trim(Target.Value)) = 0 Then
        Exit Sub
      End If
      
      Set rngLookup = Worksheets("FORM DETAILS").Range("B4:D13")
  
      Application.EnableEvents = False
      
      Target.Value = Application.VLookup(Target.Value, rngLookup, 2, False)
    
      Application.EnableEvents = True

    End If
    
[B][COLOR=rgb(184, 49, 47)]    If Worksheets("OFFICIAL DRAFT").Range("B15:B50") = "K" Then[/COLOR][/B]
[COLOR=rgb(184, 49, 47)][B]
    If Not Intersect(Target, Range("H15:H50")) Is Nothing Then
        
      If Len(Trim(Target.Value)) = 0 Then
        Exit Sub
      End If
      
      Set rngLookup = Worksheets("KIA").Range("P2:R75")
  
      Application.EnableEvents = False
      
      Target.Value = Application.VLookup(Target.Value, rngLookup, 2, False)
    
      Application.EnableEvents = True
    End If
    
    Else
    
    If Worksheets("OFFICIAL DRAFT").Range("B15:B50") = "H" Then
    
    If Not Intersect(Target, Range("H15:H50")) Is Nothing Then
        
      If Len(Trim(Target.Value)) = 0 Then
        Exit Sub
      End If
      
      Set rngLookup = Worksheets("HYUNDAI").Range("P2:R107")
  
      Application.EnableEvents = False
      
      Target.Value = Application.VLookup(Target.Value, rngLookup, 2, False)
    
      Application.EnableEvents = True
    End If
    End If
    End If
    [/B][/COLOR]
[B][COLOR=rgb(184, 49, 47)]End Sub[/COLOR][/B]

Currently I get a "type mismatch" error 13 when I enter anything in those cells.

I hope this is clear enough.

Thanks in advance for your help.
 
Sort by date Sort by votes
Joe4 said:
Upload the file to a file sharing site, and provide a link to it in this thread. I will look at it later tonight when I am at a computer where I can download files.
Click to expand...
Here's a link to the file. I use Box.com. If you get a pop-up telling you to log in or subscribe, just close that message and you will be able to access the file:

app.box.com

Drop Down Test File.xlsm | Powered by Box

app.box.com app.box.com
 
Upvote 0

Excel Facts

Remove leading & trailing spaces
Save as CSV to remove all leading and trailing spaces. It is faster than using TRIM().
OK, I got a little confused with all the different H's and K's in your post. I was updating column K on the "OFFICIAL DRAFT" sheet instead of column H.
Try this revised code:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng1 As Range, rng2 As Range
    Dim cell As Range
    Dim rngV As String
    Dim rngL As Range
       
'***PART 1: Add Data Validation to column H when column B is updated
'   See if any updates made to B15:B50
    Set rng1 = Intersect(Target, Range("B15:B50"))
    If Not rng1 Is Nothing Then
'       Loop through updated cells in column B
        For Each cell In rng1
'           Check value of column B
            Select Case cell.Value
                Case "H"
'                   Set range to Hyundai sheet
                    rngV = "=HYUNDAI!$P$2:$P$107"
                Case "K"
'                   Set range to KIA sheet
                    rngV = "=KIA!$P$2:$P$107"
                Case Else
                    rngV = ""
            End Select
           
'           Clear value in cell H
            Application.EnableEvents = False
            Cells(cell.Row, "H").ClearContents
            Application.EnableEvents = True
'           Add Data Validation in H or K selected
            If rngV <> "" Then
'               Apply Data Validation to column H of same row
                With Cells(cell.Row, "H").Validation
                    .Delete
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                    xlBetween, Formula1:=rngV
                End With
            End If
        Next cell
    End If

'***PART 2: Lookup value from table when column H id updated
'   See if any updates made to H15:H50
    Set rng2 = Intersect(Target, Range("H15:H50"))
    If Not rng2 Is Nothing Then
'       Loop through updated cells in column H
        For Each cell In rng2
'           Check value of column B
            Select Case cell.Offset(0, -6).Value
                Case "H"
'                   Set range to Hyundai sheet
                    Set rngL = Sheets("HYUNDAI").Range("P2:R107")
                Case "K"
'                   Set range to KIA sheet
                    Set rngL = Sheets("KIA").Range("P2:R107")
                Case Else
                    MsgBox "Invalid value in column B", vbOKOnly, "ERROR!"
                    Exit Sub
            End Select
'           Lookup value from 2nd column of lookup table
            Application.EnableEvents = False
            cell.Value = Application.VLookup(cell.Value, rngL, 2, False)
            Application.EnableEvents = True
        Next cell
    End If

End Sub
 
Upvote 0
Solution
Joe4 said:
OK, I got a little confused with all the different H's and K's in your post. I was updating column K on the "OFFICIAL DRAFT" sheet instead of column H.
Try this revised code:
VBA Code: 
Private Sub Worksheet_Change(ByVal Target As Range)

    Dim rng1 As Range, rng2 As Range
    Dim cell As Range
    Dim rngV As String
    Dim rngL As Range
      
'***PART 1: Add Data Validation to column H when column B is updated
'   See if any updates made to B15:B50
    Set rng1 = Intersect(Target, Range("B15:B50"))
    If Not rng1 Is Nothing Then
'       Loop through updated cells in column B
        For Each cell In rng1
'           Check value of column B
            Select Case cell.Value
                Case "H"
'                   Set range to Hyundai sheet
                    rngV = "=HYUNDAI!$P$2:$P$107"
                Case "K"
'                   Set range to KIA sheet
                    rngV = "=KIA!$P$2:$P$107"
                Case Else
                    rngV = ""
            End Select
          
'           Clear value in cell H
            Application.EnableEvents = False
            Cells(cell.Row, "H").ClearContents
            Application.EnableEvents = True
'           Add Data Validation in H or K selected
            If rngV <> "" Then
'               Apply Data Validation to column H of same row
                With Cells(cell.Row, "H").Validation
                    .Delete
                    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
                    xlBetween, Formula1:=rngV
                End With
            End If
        Next cell
    End If

'***PART 2: Lookup value from table when column H id updated
'   See if any updates made to H15:H50
    Set rng2 = Intersect(Target, Range("H15:H50"))
    If Not rng2 Is Nothing Then
'       Loop through updated cells in column H
        For Each cell In rng2
'           Check value of column B
            Select Case cell.Offset(0, -6).Value
                Case "H"
'                   Set range to Hyundai sheet
                    Set rngL = Sheets("HYUNDAI").Range("P2:R107")
                Case "K"
'                   Set range to KIA sheet
                    Set rngL = Sheets("KIA").Range("P2:R107")
                Case Else
                    MsgBox "Invalid value in column B", vbOKOnly, "ERROR!"
                    Exit Sub
            End Select
'           Lookup value from 2nd column of lookup table
            Application.EnableEvents = False
            cell.Value = Application.VLookup(cell.Value, rngL, 2, False)
            Application.EnableEvents = True
        Next cell
    End If

End Sub
Click to expand...
I think that's it!!! I'll do more testing, but this should do it. thanks so much for your help.
 
Upvote 0
You are welcome.

Please Note: In the future, when marking a post as the solution, please mark the post that contains the solution (not your own post acknowledging that some other post was the solution).
When a post is marked as the solution, it is then shown right underneath the original question so people viewing the question can easily see the question and solution in a single quick glance without having to hunt through all the posts.

I have updated this thread for you.
 
Upvote 0
Joe4 said:
You are welcome.

Please Note: In the future, when marking a post as the solution, please mark the post that contains the solution (not your own post acknowledging that some other post was the solution).
When a post is marked as the solution, it is then shown right underneath the original question so people viewing the question can easily see the question and solution in a single quick glance without having to hunt through all the posts.

I have updated this thread for you.
Click to expand...
Got it.
 
Upvote 0
You must log in or register to reply here.

Similar threads

excelbytes
  • Solved
Data Validation Show Codes Only
2 3
Replies
20
Views
374
HighAndWilder
H
M
  • Solved
Trying to apply 2 Worksheet Changes
Replies
1
Views
163
Joe4
Joe4
J
  • Solved
VBA code is not working
2
Replies
11
Views
458
smozgur
smozgur
SaraWitch
  • Solved
Run Multiple Private Sub Worksheet_Change(ByVal Target As Range)
Replies
5
Views
761
Joe4
Joe4
J
  • Solved
VBA to search or autofilter
Replies
2
Views
369
Jagat Pavasia
J

Forum statistics

Threads
1,223,877
Messages
6,175,138
Members
452,614
Latest member
MRSWIN2709

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