Cascade Table with Combobox[es] on Userform with dates

richardd8x · Mar 28th 2018

Good day

I am new to VBA.

I need help with a userform that I created to edit data from my table. When I click list drop down button on all 3 combo, they show me a very long list to choose from.

How can I narrow the list with only the same value like we click on filter drop down button on sheet filter?

And how can the second combo box only show values based on the first combo box?

I attached my file for review.

I hope someone may be able to assist me.

Thank you so much.

**pike** · Mar 29th 2018

Hello, something like ,,

Code

Private Sub cboCategory_Change()
    Dim objDict As Object, db
    Set objDict = CreateObject("Scripting.Dictionary")
    objDict.CompareMode = vbTextCompare
    With Sheets("Sheet2").ListObjects("Table2").Range
        .AutoFilter Field:=3
        .AutoFilter Field:=2
        .AutoFilter Field:=1, Criteria1:="=" & cboCategory.Value, Operator:=xlFilterValues
    End With


    Set rngArea = Sheets("Sheet2").Range("Table2").Resize(, 5).SpecialCells(12)
    For Each AreaItems In rngArea.Areas
        db = AreaItems.Value
        For xCell = LBound(db) To UBound(db)
            If Not objDict.exists(db(xCell, 2)) Then
                objDict.Add db(xCell, 2), Nothing
            End If
        Next
    Next
    Me.cboColor.List = objDict.Keys
    objDict.RemoveAll
End Sub

Display More

chirayuw · Mar 29th 2018

Looks like Pike beat me to it. Although his is a more complete solution. My offering was the tutorial link below.

http://www.thesmallman.com/blo…-non-dependent-comboboxes

richardd8x · Mar 29th 2018

Quote from pike

Hello, something like ,,

Code

Private Sub cboCategory_Change()
Dim objDict As Object, db
Set objDict = CreateObject("Scripting.Dictionary")
objDict.CompareMode = vbTextCompare
With Sheets("Sheet2").ListObjects("Table2").Range
.AutoFilter Field:=3
.AutoFilter Field:=2
.AutoFilter Field:=1, Criteria1:="=" & cboCategory.Value, Operator:=xlFilterValues
End With


Set rngArea = Sheets("Sheet2").Range("Table2").Resize(, 5).SpecialCells(12)
For Each AreaItems In rngArea.Areas
db = AreaItems.Value
For xCell = LBound(db) To UBound(db)
If Not objDict.exists(db(xCell, 2)) Then
objDict.Add db(xCell, 2), Nothing
End If
Next
Next
Me.cboColor.List = objDict.Keys
objDict.RemoveAll
End Sub

Display More

That's awesome. Thank you so much Pike.

I have changed 2 text box to sheet 2 to test.

But another issue is 2 text box not show the correct number to edit. It only cache couple rows to show. If I edit that number, it will changed to another row, not correct row like show on combo box.

How can I fix it?

Quagliano · Mar 29th 2018

Hi,

I have a file where I need to add same data on a sheet. The added data is then colored in colour. After that I need to look the data from start and look for duplication based on colored ones and normal ones and delete the no colored ones duplication, any idea how can this be done by formula macro ?

richardd8x · Mar 29th 2018

Another issue is if I change date format on Column C (Month) to "mmm-yy" or any formats which are not Short Date (m/d/yyyy). It will have error with no cells select or available.

**pike** · Mar 30th 2018

Hello,
Filtering imported dates is a tricky
The userform code

Code

Option Explicit
Private Sub cmdCancel_Click()
    Unload Me
End Sub
Private Sub cmdClear_Click()
    Me.cboCategory.ListIndex = -1
    Me.cboColor.ListIndex = -1
    Me.cboMonth.ListIndex = -1
    With Sheets("Sheet2").ListObjects("Table2").Range
        .AutoFilter Field:=3
        .AutoFilter Field:=2
        .AutoFilter Field:=1
    End With
    Me.txtboQuan.Text = vbNullString
    Me.txtboForeQuan.Text = vbNullString
End Sub
Private Sub cmdSave_Click()
    Dim rngArea As Range
    Set rngArea = Sheets("Sheet2").Range("Table2").Resize(, 5).SpecialCells(12)
    If rngArea.Count = 5 Then
    rngArea(1, 4) = UserForm1.txtboQuan.Text
    rngArea(1, 5) = UserForm1.txtboForeQuan.Text
    Reset_List
    End If
End Sub
Private Sub UserForm_Initialize()
    With Sheets("Sheet2").ListObjects("Table2").Range
        .AutoFilter Field:=3
        .AutoFilter Field:=2
        .AutoFilter Field:=1
    End With
    Reset_List
End Sub
Sub Reset_List()
    Dim objDict As Object, db, xCell
    Set objDict = CreateObject("Scripting.Dictionary")
    objDict.CompareMode = vbTextCompare
    With Worksheets("Sheet2")
        For Each xCell In .Range("A2:A" & .Cells(.Rows.Count, 1).End(xlUp).Row + 1)
            If Not objDict.exists(xCell.Value) Then
                objDict.Add xCell.Value, Nothing
            End If
        Next xCell
    End With
    Me.cboCategory.List = objDict.Keys
    objDict.RemoveAll
End Sub
Private Sub cboCategory_Change()
    Dim objDict As Object, db
    Dim rngArea As Range, AreaItems, xCell
    Set objDict = CreateObject("Scripting.Dictionary")
    objDict.CompareMode = vbTextCompare
    With Sheets("Sheet2").ListObjects("Table2").Range
        .AutoFilter Field:=3
        .AutoFilter Field:=2
        .AutoFilter Field:=1, Criteria1:="=" & cboCategory.Value, Operator:=xlFilterValues
    End With
    Set rngArea = Sheets("Sheet2").Range("Table2").Resize(, 5).SpecialCells(12)
    For Each AreaItems In rngArea.Areas
        db = AreaItems.Value
        For xCell = LBound(db) To UBound(db)
            If Not objDict.exists(db(xCell, 2)) Then
                objDict.Add db(xCell, 2), Nothing
            End If
        Next
    Next
    Me.cboColor.List = objDict.Keys
    objDict.RemoveAll
End Sub
Private Sub cboColor_Change()
    Dim objDict As Object, db
    Dim rngArea As Range, AreaItems, xCell
    Set objDict = CreateObject("Scripting.Dictionary")
    objDict.CompareMode = vbTextCompare
    If Not cboColor.Value = vbNullString Then
    With Sheets("Sheet2").ListObjects("Table2").Range
        .AutoFilter Field:=3
        .AutoFilter Field:=2
        .AutoFilter Field:=1, Criteria1:="=" & cboCategory.Value, Operator:=xlFilterValues
        .AutoFilter Field:=2, Criteria1:="=" & cboColor.Value, Operator:=xlFilterValues
    End With
  
    Set rngArea = Sheets("Sheet2").Range("Table2").Resize(, 5).SpecialCells(12)
    For Each AreaItems In rngArea.Areas
        db = AreaItems.Value
        For xCell = LBound(db) To UBound(db)
            If Not objDict.exists(CStr(CDate(db(xCell, 3)))) Then
                objDict.Add CStr(CDate(db(xCell, 3))), Nothing
            End If
        Next
    Next
    Me.cboMonth.List = objDict.Keys
    objDict.RemoveAll
    End If
End Sub
Private Sub cboMonth_Change()
    Dim txtboQuan As Integer
    Dim txtboForeQuan As Integer
    Dim rngArea As Range, AreaItems, xCell
    Dim objDict As Object, db
     If Not cboMonth.Value = vbNullString Then
    Set objDict = CreateObject("Scripting.Dictionary")
    objDict.CompareMode = vbTextCompare
    With Sheets("Sheet2").ListObjects("Table2").Range
        .AutoFilter Field:=3
        .AutoFilter Field:=2
        .AutoFilter Field:=1
        .AutoFilter Field:=1, Criteria1:="=" & cboCategory.Value, Operator:=xlFilterValues
        .AutoFilter Field:=2, Criteria1:="=" & cboColor.Value, Operator:=xlFilterValues
        .AutoFilter Field:=3, Criteria1:="=" & CStr(CDate(cboMonth.Value)), Operator:=xlFilterValues
    End With
    Set rngArea = Sheets("Sheet2").Range("Table2").Resize(, 5).SpecialCells(12)
    UserForm1.txtboQuan.Text = rngArea(1, 4)
    UserForm1.txtboForeQuan.Text = rngArea(1, 5)
    End If
End Sub

Display More

**pike** · Mar 30th 2018

Oh the workbook too

richardd8x · Mar 30th 2018

That 's perfect. Thank you so much for your help Pike. I appreciative your help.

**pike** · Mar 30th 2018

No problem,, there is a bit of unneeded syntax in the code like all the

Code

objDict.RemoveAll

. what was I thinking
I'll also change the Thread title to Cascade Table with comboboxes in userform with dates

Cascade Table with Combobox[es] on Userform with dates

Participate now!

Share

Users Viewing This Thread