Dynamic Data Validation List

[Bkisley]

Hello experts!
I have a form my users will fill out. On this form there will be two columns that will require drop downs.
Right now I have the inefficient way of having two completely separate lists when in reality what I need is to have my 2nd drop down dynamic based on the 1st column drop down

On my "Welcome" tab - Cells A50:A100 is my "Main Category" header/values and cells B50:B100 is my "Subcategory" header/values
The user will fill out this welcome tab initially to set up their own personalized document.
Example: The user could type in "Painting" in cell A51 "Plumbing" in cell A52 and "Interior" in B51 and and "Residential" in B52

What I need is for my 2nd drop down to be based on what is chosen in my first drop down SO if the user selects "Painting" in my first drop down the only option based in the above example that would show up is "Interior". The option for "residential should not show up!. The reverse is true if the user selects "Plumbing" only "Residential" should should

Currently my drop downs are pulling from a pivot table that was created so I only have unique values for my Main Category values and a separate pivot table for my Sub category values. Obviously the issue that has is my 2nd drop down could have 50 options that really are not options that are paired with my first drop down selection.

My range of categories has to be dynamic - currently in a table to do this.
There has to be an efficienty way to do this!

 

[maabadi]

Also you can use this. I test it on Your file.
It transposed your data to after column E and then define named ranges. then get data validation at green color Cells.
you can change range to what you wants.

Sub UniqueListTransposed()
Dim Lr As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim m As Long
Dim l As Long
Dim n As String
Lr = Cells(Rows.Count, 1).End(xlUp).Row

ActiveSheet.Range("A2:A" & Lr).AdvancedFilter Action:=xlFilterCopy, _
     CopyToRange:=ThisWorkbook.Worksheets("Sheet1").Range("E1"), Unique:=True

With ThisWorkbook.Worksheets("Sheet1")
    .Range(.Range("E2"), .Range("E1").End(xlDown)).Copy
    .Range("F1").PasteSpecial xlPasteValues, Transpose:=True
    .Columns("E").EntireColumn.ClearContents
    '.Range("E1").Value = "MainCategory"
End With
For i = 2 To Lr
Range("C" & i).Value = Range("A" & i).Value & Application.WorksheetFunction.CountIf(Range("A2:A" & i), Range("A" & i))
Next i

 For j = 6 To Cells(1, Columns.Count).End(xlToLeft).Column
  For i = 2 To Application.WorksheetFunction.CountIf(Range("A2:A" & Lr), Cells(1, j)) + 1
  l = Application.WorksheetFunction.CountA(Range(Cells(2, 5), Cells(Lr, j - 1)))
  k = Application.WorksheetFunction.CountIf(Range("A2:A" & i + l), Cells(1, j))
  m = Application.WorksheetFunction.Match(Cells(1, j) & k, Range("C2:C" & Lr), 0)
  Cells(i, j).Value = Application.WorksheetFunction.Index(Range("A2:C" & Lr), m, 2)
 
 Next i
 n = Replace(Cells(1, j), " ", "")
 n = Replace(n, "/", "")
 Cells(1, j).Value = n
 Names.Add Name:=n, RefersTo:=Range(Cells(2, j), Cells(k + 1, j))
Next j
Names.Add Name:="MainList", RefersTo:=Range(Cells(1, 6), Cells(1, j))
Range(Cells(1, 6), Cells(16, j)).Interior.ColorIndex = 35
With Range("F20").Validation
    .Delete 'delete previous validation
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=MainList"
    
End With
 Range("F20").Value = Cells(1, 6).Value
 Range("F20").Interior.ColorIndex = 6
With Range("G20").Validation
    .Delete 'delete previous validation
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=Indirect(F20)"
    'xlValidAlertStop,
End With
 Range("G20").Interior.ColorIndex = 6
End Sub

 

[Bkisley]

This works perfectly in this sheet you created for me so first of THANK YOU
I am struggling taking your code and integrating it into my full file.
2 things are happening first....on the tab that I put the code on --> literally any cell I click on I get a pop up that says "Error number: 1004 Method 'Range' of object '_Worksheet' failed.

If I click in the cell that has the first data validation and click OK out of the above error, I can use the drop down, but nothing shows up. I have no clue how in the file you sent over the xName works. I can delete everything in column F so there is nothing there, go back and click the drop down and all of a sudden there are values back in column F for my first drop down. My file is not doing this... so I can choose anything in my first drop down.

Maybe this will help... Below is how your code looks with my edits. My edits to your code are noted in ALL CAPS.

Once again THANK YOU FOR ALL YOUR HELP SO FAR!

'=================================================================================================
'=============== YOU MAY NEED TO ADJUST THE CODE IN THIS PART: ===================================

'sheet's name where the list for data validation is located.         THIS WAS SHEET2
Private Const sList As String = "DataValidation"

'table's name where the list for data validation is located.        THIS WAS TABLE11
Private Const sTable As String = "CategoryTable2"

'range where data validation is located
Private Const sDV1 As String = "C12:C17"  ' for data validation 1    THIS WAS A2:A10
Private Const sDV2 As String = "D12:D17"  ' for data validation 2    THIS WAS C2:C10

'the helper column, first cell [if the helper column is D then it must be "D1"]    THIS WAS F1
Private Const xH As String = "AX1"

'the name range as the source of data validation
Private Const xN As String = "xName"
'==================================================================================================
'==================================================================================================


Private Sub Worksheet_SelectionChange(ByVal Target As Range)

If Target.Cells.CountLarge = 1 Then
    On Error GoTo skip:
    If Not Intersect(Target, Union(Range(sDV1), Range(sDV2))) Is Nothing Then
        Dim d As Object, va, flag As Boolean
        Dim sTarget1 As String, sTarget2 As String
        Dim i As Long, j As Long, k As Long
        
        flag = True
        If Target.Column = Range(sDV1).Column Then
            Set d = CreateObject("scripting.dictionary"):  d.CompareMode = vbTextCompare
            va = Sheets(sList).ListObjects(sTable).DataBodyRange.Columns(1).Value
            
                'populating unique value for the list in DV1
                For i = 1 To UBound(va, 1)
                d(va(i, 1)) = Empty
                Next
            
        ElseIf Target.Column = Range(sDV2).Column Then
            
                j = Range(sDV1).Column - Range(sDV2).Column
                'if col 1 is blank
                sTarget = Target.Offset(, j).Value
                If sTarget = "" Then
                    flag = False
                    ThisWorkbook.Names(xN).RefersTo = Cells(1, Columns.Count)
                Else
                    Set d = CreateObject("scripting.dictionary"):  d.CompareMode = vbTextCompare
    
                    va = Sheets(sList).ListObjects(sTable).DataBodyRange.Columns("AQ:AR").Value
                
                    'populating the list in DV2 using col 1  as criteria         THE AQ:AR ABOVE WAS A:B
                    For i = 1 To UBound(va, 1)
                    If va(i, 1) = sTarget Then d(va(i, 2)) = Empty
                    Next
                End If
        End If
        
        If flag = True Then
            Dim c As Range
            Application.EnableEvents = False
            Application.ScreenUpdating = False
            With Sheets(sList)
                .Columns(.Range(xH).Column).ClearContents
                Set c = .Range(xH).Resize(d.Count, 1)
                c = Application.Transpose(Array(d.Keys))
                
                'if the list needs to be sorted then comment out this line below:
                c.Sort Key1:=c.Cells(1), Order1:=xlAscending, Header:=xlNo
                
            End With
            'populating range to named range
            ThisWorkbook.Names(xN).RefersTo = c
            Application.ScreenUpdating = True
            Application.EnableEvents = True
        End If

    End If
Else
    If Not Intersect(Target, Union(Range(sDV1), Range(sDV2))) Is Nothing Then
        ThisWorkbook.Names(xN).RefersTo = Cells(1, Columns.Count)
    End If
End If

Exit Sub
skip:
MsgBox "Error number: " & Err.Number & vbCr & Err.Description
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Cells.CountLarge <> 1 Then Exit Sub
    If Not Intersect(Target, Union(Range(sDV1), Range(sDV2))) Is Nothing Then
        Dim q As Long
        On Error GoTo skip:
       
        Application.EnableEvents = False
            'if col 1 changes then clear col 2 & 3
            If Target.Column = Range(sDV1).Column Then
                q = Range(sDV2).Column - Range(sDV1).Column: Target.Offset(, q).ClearContents

            End If
        Application.EnableEvents = True
    
    End If
    
Exit Sub

skip:
MsgBox "Error number: " & Err.Number & vbCr & Err.Description
Application.EnableEvents = True
End Sub

Sub ddddddd()
Application.EnableEvents = True
End Sub


'            'if col 1 is blank then the list in DV2 should be blank too
'            If Len(Target.Offset(, -1)) = 0 Then
'            ActiveWorkbook.Names.Add Name:=xN, RefersTo:=Cells(1, Columns.Count)
'            Exit Sub
'            End If

 

[Akuini]

"Error number: 1004 Method 'Range' of object '_Worksheet' failed.

I have no clue how in the file you sent over the xName works.

In post #10 I explained in the instruction on how to set it up, you need create a named range “xName”, refers to a cell, any cell will do.

If you still have problem, can you upload your file (without sensitive data)?

 

[Akuini]

Sorry, you're maybe confused about the name range, because in the other file I use "xHelp" not "xName".
So in this case, just use "xName" as the named range & as the source of data validation.

 

[Bkisley]

I looked at what cells were part of the xName range in name manager and used that same logic on my file. I don't have it in front of me but I thought it was like F1:F5? I might be wrong. But whatever that used I used my equivalent. I'll mess with it later tonight and get back to you.

 

[Bkisley]

@maabadi - I just copied your code over to the file I attached earlier and it worked! I will have to go through and read that code so I understand what it is all doing...but whatever it is doing, it seems to be working perfectly. Hopefully I can integrate this or the one Akuini is doing.

More to come from me...thank you!!!

 

[maabadi]

You're welcome & thanks for feedback

 

[Bkisley]

ok @maabadi I tried...several times...sorry but I will need a little more help from you

on my full file the columns where I have my main category and subcategory are actually AJ and AK.
I thought it would be easy enough to just translate that over aka wherever in your code you reference column A I would reference column AJ
I used this as my translation... A = AJ B=AK C=AL D=AM E=AN F=AO G=AP

When I run this code the error happens at the below.

Names.Add Name:=n, RefersTo:=Range(Cells(2, j), Cells(k + 1, j))

Full updated code is as follows. All I changed were columns per above and the sheet name from sheet1 to data validation. Do you know what else I could have missed??

Sub UniqueListTransposed()
Dim Lr As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim m As Long
Dim l As Long
Dim n As String
Lr = Cells(Rows.Count, 1).End(xlUp).Row

'Convert original code to match my columns  A = AJ   B=AK   C=AL   D=AM   E=AN    F=AO   G=AP

ActiveSheet.Range("AJ2:AJ" & Lr).AdvancedFilter Action:=xlFilterCopy, _
     CopyToRange:=ThisWorkbook.Worksheets("Data Validation").Range("AN1"), Unique:=True

With ThisWorkbook.Worksheets("Data Validation")
    .Range(.Range("AN2"), .Range("AN1").End(xlDown)).Copy
    .Range("AO1").PasteSpecial xlPasteValues, Transpose:=True
    .Columns("AN").EntireColumn.ClearContents
    '.Range("AN1").Value = "MainCategory"
End With
For i = 2 To Lr
Range("AL" & i).Value = Range("AJ" & i).Value & Application.WorksheetFunction.CountIf(Range("AJ2:AJ" & i), Range("AJ" & i))
Next i

 For j = 6 To Cells(1, Columns.Count).End(xlToLeft).Column
  For i = 2 To Application.WorksheetFunction.CountIf(Range("AJ2:AJ" & Lr), Cells(1, j)) + 1
  l = Application.WorksheetFunction.CountA(Range(Cells(2, 5), Cells(Lr, j - 1)))
  k = Application.WorksheetFunction.CountIf(Range("AJ2:AJ" & i + l), Cells(1, j))
  m = Application.WorksheetFunction.Match(Cells(1, j) & k, Range("AL2:AL" & Lr), 0)
  Cells(i, j).Value = Application.WorksheetFunction.Index(Range("AJ2:AL" & Lr), m, 2)
 
 Next i
 n = Replace(Cells(1, j), " ", "")
 n = Replace(n, "/", "")
 Cells(1, j).Value = n
 Names.Add Name:=n, RefersTo:=Range(Cells(2, j), Cells(k + 1, j))
Next j
Names.Add Name:="MainList", RefersTo:=Range(Cells(1, 6), Cells(1, j))
Range(Cells(1, 6), Cells(16, j)).Interior.ColorIndex = 35
With Range("AO20").Validation
    .Delete 'delete previous validation
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=MainList"
    
End With
 Range("AO20").Value = Cells(1, 6).Value
 Range("AO20").Interior.ColorIndex = 6
With Range("AP20").Validation
    .Delete 'delete previous validation
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=Indirect(AO20)"
    'xlValidAlertStop,
End With
 Range("AP20").Interior.ColorIndex = 6
End Sub

 

[maabadi]

When Use Cells(i, j) , i equal row number at your sheet and j equal to column number . then You should change:

Sub UniqueListTransposed()
Dim Lr As Long
Dim i As Long
Dim j As Long
Dim k As Long
Dim m As Long
Dim l As Long
Dim n As String
Lr = Cells(Rows.Count, 36).End(xlUp).Row

'Convert original code to match my columns  A = AJ   B=AK   C=AL   D=AM   E=AN    F=AO   G=AP

ActiveSheet.Range("AJ2:AJ" & Lr).AdvancedFilter Action:=xlFilterCopy, _
     CopyToRange:=ThisWorkbook.Worksheets("Data Validation").Range("AN1"), Unique:=True

With ThisWorkbook.Worksheets("Data Validation")
    .Range(.Range("AN2"), .Range("AN1").End(xlDown)).Copy
    .Range("AO1").PasteSpecial xlPasteValues, Transpose:=True
    .Columns("AN").EntireColumn.ClearContents
    '.Range("AN1").Value = "MainCategory"
End With
For i = 2 To Lr
Range("AL" & i).Value = Range("AJ" & i).Value & Application.WorksheetFunction.CountIf(Range("AJ2:AJ" & i), Range("AJ" & i))
Next i

 For j = 36 To Cells(1, Columns.Count).End(xlToLeft).Column
  For i = 2 To Application.WorksheetFunction.CountIf(Range("AJ2:AJ" & Lr), Cells(1, j)) + 1
  l = Application.WorksheetFunction.CountA(Range(Cells(2, 35), Cells(Lr, j - 1)))
  k = Application.WorksheetFunction.CountIf(Range("AJ2:AJ" & i + l), Cells(1, j))
  m = Application.WorksheetFunction.Match(Cells(1, j) & k, Range("AL2:AL" & Lr), 0)
  Cells(i, j).Value = Application.WorksheetFunction.Index(Range("AJ2:AL" & Lr), m, 2)
 
 Next i
 n = Replace(Cells(1, j), " ", "")
 n = Replace(n, "/", "")
 Cells(1, j).Value = n
 Names.Add Name:=n, RefersTo:=Range(Cells(2, j), Cells(k + 1, j))
Next j
Names.Add Name:="MainList", RefersTo:=Range(Cells(1, 36), Cells(1, j))
Range(Cells(1, 36), Cells(16, j)).Interior.ColorIndex = 35
With Range("AO20").Validation
    .Delete 'delete previous validation
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=MainList"
    
End With
 Range("AO20").Value = Cells(1, 36).Value
 Range("AO20").Interior.ColorIndex = 6
With Range("AP20").Validation
    .Delete 'delete previous validation
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Formula1:="=Indirect(AO20)"
    'xlValidAlertStop,
End With
 Range("AP20").Interior.ColorIndex = 6
End Sub

 

[Bkisley]

ok. Finally got back to working on this just now. When I use that VBA I now get a pop up that just says "400" no clue what that means