Dependent dropdown list in excel using VBA Code

[deba2020]

I have a workbook with 2 sheets in it
Sheet1 Name = Vendor
Sheet2 Name = Payment

In Sheet(Vendor) I have details of the vendor base of my organisation

Vendor Code	Site	Vendor Name
1	AUSTRALIA	Supplier1
2	FLORIDA	Supplier2
3	MALAYSIA.	Supplier3
4	P. R. CHINA	Supplier4
5	GERMANY	Supplier5
6	JEDDAH	Supplier6
7	DUBAI	Supplier7
7	SWITZERLAND	Supplier7
7	UNITED STATES	Supplier7
7	BJN-SWITZERLAND	Supplier7

In Sheet(Payment) if I enter Vendor Code in any cell in Column D the VBA code should look Sheet(Vendor) for the vendor code and list the sites of the vendor in drop down list in Column H

Date	Date	RTGS/NEFT REF	V Code	Party	Amount	Trading Partner	Site
1	04-Feb-23	0	4424	MSEDCL		MISCELLANEOUS VENDOR

Should you have any query please ask.

 

[shinigamilight]

Paste this code in a module

Sub Lookupstuff(ByRef Finder As Range, SearchString As String)
        Dim wk1 As Worksheet
        Set wk1 = Sheets("Vendor")
        Dim V
        Dim K As Long
        
        On Error Resume Next
        With wk1
                V = .Range("A2:B" & .Range("A" & Rows.Count).End(xlUp).Row)
                For K = 1 To UBound(V, 1)
                       If V(K, 1) = Finder.Value Then
                            SearchString = SearchString & "," & V(K, 2)
                        End If
                Next K
        End With
         SearchString = Right(SearchString, Len(SearchString) - 1)
        
        
        
End Sub

Paste this code in the "Payment" worksheet's worksheet change event

Private Sub Worksheet_Change(ByVal Target As Range)
        On Error Resume Next
        Dim Temp As String
        If Target.Cells.Count > 1 Then Exit Sub

        If Intersect(Target, Range("D:D")) Is Nothing Then Exit Sub
                
                Target.Offset(0, 4).Validation.Delete           'it will clear all of the previous validations in the column H
                Target.Offset(0, 4).ClearContents
                Lookupstuff Target, Temp
                ActiveSheet.Range(Target.Offset(0, 4).Address(0, 0)).Validation.Add xlValidateList, , , Temp
                
End Sub

 

[deba2020]

Paste this code in a module

Sub Lookupstuff(ByRef Finder As Range, SearchString As String)
        Dim wk1 As Worksheet
        Set wk1 = Sheets("Vendor")
        Dim V
        Dim K As Long
       
        On Error Resume Next
        With wk1
                V = .Range("A2:B" & .Range("A" & Rows.Count).End(xlUp).Row)
                For K = 1 To UBound(V, 1)
                       If V(K, 1) = Finder.Value Then
                            SearchString = SearchString & "," & V(K, 2)
                        End If
                Next K
        End With
         SearchString = Right(SearchString, Len(SearchString) - 1)
       
       
       
End Sub

Paste this code in the "Payment" worksheet's worksheet change event

Private Sub Worksheet_Change(ByVal Target As Range)
        On Error Resume Next
        Dim Temp As String
        If Target.Cells.Count > 1 Then Exit Sub

        If Intersect(Target, Range("D:D")) Is Nothing Then Exit Sub
               
                Target.Offset(0, 4).Validation.Delete           'it will clear all of the previous validations in the column H
                Target.Offset(0, 4).ClearContents
                Lookupstuff Target, Temp
                ActiveSheet.Range(Target.Offset(0, 4).Address(0, 0)).Validation.Add xlValidateList, , , Temp
               
End Sub

Thank you very much, it worked like gem.