CODEWITHSUNDEEP
excelvba
LOUIS SKINNY
LOUIS SKINNY

Reputation: 73

How to create a dropdown list from data VBA

I have a issue trying to make a dropdown list from specific data. What I need to do here is to make a dropdown list to categories A, B and C containing the cities that correspond to them as they are shown in column B

enter image description here

I tried my best but couldn't do that much to solve the code:

Sub AddData()

Dim AStr As String
Dim Value, Colum As Variant
 

For Colum = 7 to 10
If Sheets("Sheet1").Cells(Colum,2) = Sheets("Sheet1").Range("A:A")

Then

For Each Value In Range("B1:B" & Lrow)
    AStr = AStr & "," & Value
Next Value
 
AStr = Right(AStr, Len(AStr) - 1)
 
With Worksheets("Sheet1").Cells("G3:I3").Validation
    .Delete
    .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:= _
    xlBetween, Formula1:=AStr
    .IgnoreBlank = True
    .InCellDropdown = True
    .InputTitle = ""
    .ErrorTitle = ""
    .InputMessage = ""
    .ErrorMessage = ""
    .ShowInput = True
    .ShowError = True
End With
 
End If
Next
End Sub

If anyone know how to figure out this, I will thank you very much!

Upvotes: 2

Views: 350

Answers (1)

VBasic2008
VBasic2008

Reputation: 54777

Multiple Data Validation Lists

  • With the current setup, in the worksheet Sheet1 of the workbook containing this code (ThisWorkbook), finds the values of the range G2:H2 in the range A6:ALastRow and uses the size of the found cells' merged areas to assign the corresponding values of column B to data validation lists for the cells in the range G3:H3.
Option Explicit

Sub MultiDataValidation()
    
    Const sName As String = "Sheet1"
    Const scCol As String = "A"
    Const svCol As String = "B"
    Const sfRow As Long = 6
    
    Const dName As String = "Sheet1"
    Const dcAddress As String = "G2:I2"
    Const dvRow As Long = 3
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    Dim sws As Worksheet: Set sws = wb.Worksheets(sName)
    Dim slRow As Long: slRow = sws.Cells(sws.Rows.Count, svCol).End(xlUp).Row
    If slRow < sfRow Then Exit Sub ' no data
    Dim srCount As Long: srCount = slRow - sfRow + 1
    Dim scrg As Range: Set scrg = sws.Cells(sfRow, scCol).Resize(srCount)
    
    Dim dws As Worksheet: Set dws = wb.Worksheets(dName)
    Dim dcrg As Range: Set dcrg = dws.Range(dcAddress)
    
    Dim srg As Range
    Dim sCell As Range
    Dim srIndex As Variant
    Dim dCell As Range
    
    For Each dCell In dcrg.Cells
        srIndex = Application.Match(dCell.Value, scrg, 0)
        If IsNumeric(srIndex) Then
            Set sCell = scrg.Cells(srIndex)
            If sCell.MergeCells Then
                Set srg = sCell.MergeArea
            Else
                Set srg = sCell
            End If
            With dCell.EntireColumn.Rows(dvRow).Validation
                .Delete
                .Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, _
                    Formula1:="=" & srg.EntireRow.Columns(svCol).Address
                .IgnoreBlank = True
                .InCellDropdown = True
                .InputTitle = ""
                .ErrorTitle = ""
                .InputMessage = ""
                .ErrorMessage = ""
                .ShowInput = True
                .ShowError = True
            End With
        End If
    Next dCell
    
End Sub

Upvotes: 2

Related Questions