Add unique Items to ListBox Dynamically

Option Explicit

Private dic As Object

Private Sub UserForm_Initialize()
    Dim a, i As Long
    Set dic = CreateObject("Scripting.Dictionary")
    dic.CompareMode = 1
    a = Sheets("sheet1").Cells(1).CurrentRegion
    For i = 2 To UBound(a, 1)
        If Not dic.exists(a(i, 3)) Then
            Set dic(a(i, 3)) = CreateObject("Scripting.Dictionary")
        End If
        dic(a(i, 3))(a(i, 2)) = Array(a(i, 1), a(i, 2))
    Next
    Me.ComboBox1.List = dic.keys
End Sub

Private Sub ComboBox1_Change()
    Me.ListBox1.Clear
    With Me.ComboBox1
        If .ListIndex > -1 Then
            If dic(.Value).Count > 1 Then
                Me.ListBox1.List = Application.Index(dic(.Value).items, 0, 0)
            Else
                Me.ListBox1.Column = Application.Index(dic(.Value).items, 0, 0)
            End If
        End If
    End With
End Sub

Just change ColumnCount property to 2

        dic(a(i, 3))(a(i, 2)) = Array(a(i, 1), a(i, 2), a(i, 5), a(i, 6))