Question : Excel dependable Dropdowns

Excel issue (may be limitiation)...I tried to search for solutions but without any luck...I have attached the sample excel file for better understanding.

So, I need to set dropdown list for first 4 columns (Dependable dropdowns), my problem is if I select the region as west then I want only state, ID & code to be displayed for "West" region and if I select particular state then only related other filters should be displayed and update the data fields.

This is just a simple file, I am dealing with 5000+ rows and excel only is my option since this will be distributed. I tried looking up each row for particular value and check duplicates ect....but very slow and not the decent way to do it....

Any help would be greatly apprecaited.

Thank you.

Answer : Excel dependable Dropdowns

hitsdoshi1,

The code below is in the attached workbook. Make the selections from the dropdowns in the yellow cells and the totals will be shown below. The totals are produced using this sort of formula:

=SUMPRODUCT(($A$2:$A$10000=$J$1)*($B$2:$B$10000=$J$2)*($C$2:$C$10000=$M$1)*($D$2:$D$10000=$M$2)*$E$2:$E$10000)

Hope that helps

Patrick

                       
         
           
             1:
2:
3:
4:
5:
6:
7:
8:
9:
10:
11:
12:
13:
14:
15:
16:
17:
18:
19:
20:
21:
22:
23:
24:
25:
26:
27:
28:
29:
30:
31:
32:
33:
34:
35:
36:
37:
38:
39:
40:
41:
42:
43:
44:
45:
46:
47:
48:
49:
50:
51:
52:
53:
54:
55:
56:
57:
58:
59:
60:
61:
62:
63:
64:
65:
66:
67:
68:
69:
70:
71:
72:
73:
74:
75:
76:
77:
78:
79:
80:
81:
82:
83:
84:
85:
86:
87:
88:
89:
90:
91:
92:
93:
94:
95:
96:
97:
98:
99:
100:
101:
102:
103:
104:
105:
106:
107:
108:
109:
110:
111:
112:
113:
114:
115:
116:
117:
118:
119:
120:
121:
122:
123:
124:
125:
126:
127:
128:
129:
130:
131:
132:
133:
134:
135:
136:
137:
138:
139:
140:
141:
142:
143:
144:
145:
146:
147:
148:
149:
150:
151:
152:
153:
154:
155:
156:
157:
158:
159:
160:
161:
162:
163:
164:
165:
166:
167:
168:
169:
170:
171:
172:
173:
174:
175:
176:
177:
178:
179:
180:
181:
182:
183:
184:
185:
186:
187:
188:
189:
190:
191:
192:
193:
194:
195:
196:
197:
198:
199:
200:
201:
202:
203:
204:
205:
206:
207:
208:
209:
210:
211:
212:
213:
214:
215:
216:
217:
218:
219:
220:
221:
222:
223:
224:
225:

           
           
             In an ordinary VBA Module:

Option Explicit
Option Base 1

Sub region_dropdown()
Dim coll As New Collection
Dim rng As Range
Dim celle As Range
Dim str1 As String
Dim str2 As String
Dim rowe As Long
Dim i As Long
Dim n As Long
Dim temp As String
Dim coll_arr() As String

rowe = 2
str1 = "A"
str2 = "A"
With Sheets("Sheet1")
    Set rng = Range(.Cells(rowe, str1), .Cells(.Cells.Rows.Count, str2).End(xlUp))
End With

For Each celle In rng
        On Error Resume Next
        coll.Add celle, celle
Next celle

ReDim coll_arr(coll.Count)

For i = 1 To coll.Count
    coll_arr(i) = coll(i)
Next i

temp = ""
For n = 1 To coll.Count
    For i = 1 To coll.Count
        If coll_arr(n) < coll_arr(i) Then
            temp = coll_arr(n)
            coll_arr(n) = coll_arr(i)
            coll_arr(i) = temp
            If i = coll.Count Then
                coll_arr(coll.Count) = temp
            End If
            temp = ""
        End If
    Next i
Next n

With Sheets("Lists")
    For i = 1 To UBound(coll_arr)
        .Cells(i + 1, 1) = coll_arr(i)
    Next i
End With

End Sub

In Worksheet_Change for Sheet1:

Option Explicit
Option Base 1

Private Sub Worksheet_Change(ByVal Target As Range)
Dim coll As New Collection
Dim rng As Range
Dim celle As Range
Dim str1 As String
Dim str2 As String
Dim rowe As Long
Dim i As Long
Dim n As Long
Dim temp As String
Dim coll_arr() As String

'check for a change in the Region cell J1
If Not Intersect(Sheets("Sheet1").[J1], Target) Is Nothing Then
    rowe = 2
    str1 = "B"
    str2 = "B"
    With Sheets("Sheet1")
        Set rng = Range(.Cells(rowe, str1), .Cells(.Cells.Rows.Count, str2).End(xlUp))
    End With
    
    For Each celle In rng
        If celle.Offset(0, -1) = Sheets("Sheet1").[J1] Then
            On Error Resume Next
            coll.Add celle, celle
        End If
    Next celle
    
    On Error Resume Next
    ReDim coll_arr(coll.Count)
    
    For i = 1 To coll.Count
        coll_arr(i) = coll(i)
    Next i
    
    temp = ""
    For n = 1 To coll.Count
        For i = 1 To coll.Count
            If coll_arr(n) < coll_arr(i) Then
                temp = coll_arr(n)
                coll_arr(n) = coll_arr(i)
                coll_arr(i) = temp
                If i = coll.Count Then
                    coll_arr(coll.Count) = temp
                End If
                temp = ""
            End If
        Next i
    Next n
    
    With Sheets("Sheet1")
        .[J2].ClearContents
        .[M1].ClearContents
        .[M2].ClearContents
    End With
    
    With Sheets("Lists")
        .Range(.Cells(2, "B"), .Cells(65536, "B")).ClearContents
        For i = 1 To UBound(coll_arr)
            .Cells(i + 1, "B") = coll_arr(i)
        Next i
    End With
End If

'check for a change in the State cell J2
If Not Intersect(Sheets("Sheet1").[J2], Target) Is Nothing Then
    rowe = 2
    str1 = "C"
    str2 = "C"
    With Sheets("Sheet1")
        Set rng = Range(.Cells(rowe, str1), .Cells(.Cells.Rows.Count, str2).End(xlUp))
    End With
    
    For Each celle In rng
        If celle.Offset(0, -1) = Sheets("Sheet1").[J2] Then
            On Error Resume Next
            coll.Add celle, celle
        End If
    Next celle
    
    On Error Resume Next
    ReDim coll_arr(coll.Count)
    
    For i = 1 To coll.Count
        coll_arr(i) = coll(i)
    Next i
    
    temp = ""
    For n = 1 To coll.Count
        For i = 1 To coll.Count
            If coll_arr(n) < coll_arr(i) Then
                temp = coll_arr(n)
                coll_arr(n) = coll_arr(i)
                coll_arr(i) = temp
                If i = coll.Count Then
                    coll_arr(coll.Count) = temp
                End If
                temp = ""
            End If
        Next i
    Next n
    
    With Sheets("Sheet1")
        .[M1].ClearContents
        .[M2].ClearContents
    End With
    
    With Sheets("Lists")
        .Range(.Cells(2, "C"), .Cells(65536, "C")).ClearContents
        For i = 1 To UBound(coll_arr)
            .Cells(i + 1, "C") = coll_arr(i)
        Next i
    End With
End If

'check for a change in the ID cell M1
If Not Intersect(Sheets("Sheet1").[M1], Target) Is Nothing Then
    rowe = 2
    str1 = "D"
    str2 = "D"
    With Sheets("Sheet1")
        Set rng = Range(.Cells(rowe, str1), .Cells(.Rows.Count, str2).End(xlUp))
    End With
    
    For Each celle In rng
        If celle.Offset(0, -1) = Sheets("Sheet1").[M1] Then
            On Error Resume Next
            coll.Add CStr(celle), CStr(celle)
        End If
    Next celle
    On Error Resume Next
    ReDim coll_arr(coll.Count)
    
    For i = 1 To coll.Count
        coll_arr(i) = coll(i)
    Next i
    
    temp = ""
    For n = 1 To coll.Count
        For i = 1 To coll.Count
            If coll_arr(n) < coll_arr(i) Then
                temp = coll_arr(n)
                coll_arr(n) = coll_arr(i)
                coll_arr(i) = temp
                If i = coll.Count Then
                    coll_arr(coll.Count) = temp
                End If
                temp = ""
            End If
        Next i
    Next n

    Sheets("Sheet1").[M2].ClearContents
    With Sheets("Lists")
        .Range(.Cells(2, "D"), .Cells(65536, "D")).ClearContents
        For i = 1 To UBound(coll_arr)
            .Cells(i + 1, "D") = coll_arr(i)
        Next i
    End With
End If

End Sub

           
         

Open in New Window

Select All

sample1-1-.xls (56 KB) (File Type Details)

xls