[[20131105121455]]　『Comboboxリスト抽出』（KISS）　ページの最後に飛ぶ

『Comboboxリスト抽出』（KISS）Ver2010　　Win7
いつも大変お世話になっております
下記の件大変お手数ですがご教授頂けたら幸いです

以前に検索用で教えていただいたのですが
教えて頂いたのを入力用に使おうと思ったのですが
上手にいかなくて大変申し訳ございません

現状ですと　リストがすべて出てしまう為
フィルターを掛けたいと思ってます

Combobox１～９配置してまして
Combobox１を選択したときConbobox1に関連したCombobox2リスト抽出
Combobox２を選択したときConbobox２に関連したCombobox３リスト抽出
Combobox３を選択したときConbobox３に関連したCombobox４リスト抽出
Combobox４を選択したときConbobox４に関連したCombobox５リスト抽出
Combobox５を選択したときConbobox５に関連したCombobox６リスト抽出
Combobox６を選択したときConbobox６に関連したCombobox７リスト抽出

上記の様なフィルタを掛けたいのですがどの様にすればよいのでしょうか
よろしくお願いいたします
Comboboxは下記のように配置しております

Private Sub UserForm_Initialize()

Dim リスト As New Collection
Dim 列 As String, 上端セル As String, 最下端セル As String
Dim セル範囲 As Range, 各セル As Range
'

    列 = "A"
    上端セル = 列 & "2"
    最下端セル = 列 & "65536"
    With Worksheets("SSS")
        Set セル範囲 = .Range(.Range(上端セル), .Range(最下端セル).End(xlUp))
    End With
    For Each 各セル In セル範囲
        On Error Resume Next
        リスト.Add 各セル.Value, CStr(各セル.Value)
        If Err.Number = 0 Then
            Me.ComboBox1.AddItem 各セル.Value
        End If
        On Error GoTo 0
    Next
    '
    列 = "B"
    上端セル = 列 & "2"
    最下端セル = 列 & "65536"
    With Worksheets("SSS")
        Set セル範囲 = .Range(.Range(上端セル), .Range(最下端セル).End(xlUp))
    End With
    For Each 各セル In セル範囲
        On Error Resume Next
        リスト.Add 各セル.Value, CStr(各セル.Value)
        If Err.Number = 0 Then
            Me.ComboBox2.AddItem 各セル.Value
        End If
        On Error GoTo 0
    Next
    '
    列 = "C"
    上端セル = 列 & "2"
    最下端セル = 列 & "65536"
    With Worksheets("SSS")
        Set セル範囲 = .Range(.Range(上端セル), .Range(最下端セル).End(xlUp))
    End With
    For Each 各セル In セル範囲
        On Error Resume Next
        リスト.Add 各セル.Value, CStr(各セル.Value)
        If Err.Number = 0 Then
            Me.ComboBox3.AddItem 各セル.Value
        End If
        On Error GoTo 0
    Next
    '
    列 = "D"
    上端セル = 列 & "2"
    最下端セル = 列 & "65536"
    With Worksheets("SSS")
        Set セル範囲 = .Range(.Range(上端セル), .Range(最下端セル).End(xlUp))
    End With
    For Each 各セル In セル範囲
        On Error Resume Next
        リスト.Add 各セル.Value, CStr(各セル.Value)
        If Err.Number = 0 Then
            Me.ComboBox4.AddItem 各セル.Value
        End If
        On Error GoTo 0
    Next
    '
    列 = "E"
    上端セル = 列 & "2"
    最下端セル = 列 & "65536"
    With Worksheets("SSS")
        Set セル範囲 = .Range(.Range(上端セル), .Range(最下端セル).End(xlUp))
    End With
    For Each 各セル In セル範囲
        On Error Resume Next
        リスト.Add 各セル.Value, CStr(各セル.Value)
        If Err.Number = 0 Then
            Me.ComboBox5.AddItem 各セル.Value
        End If
        On Error GoTo 0
    Next
    '
    列 = "f"
    上端セル = 列 & "2"
    最下端セル = 列 & "65536"
    With Worksheets("SSS")
        Set セル範囲 = .Range(.Range(上端セル), .Range(最下端セル).End(xlUp))
    End With
    For Each 各セル In セル範囲
        On Error Resume Next
        リスト.Add 各セル.Value, CStr(各セル.Value)
        If Err.Number = 0 Then
            Me.ComboBox6.AddItem 各セル.Value
        End If
        On Error GoTo 0
    Next

      '
    列 = "G"
    上端セル = 列 & "2"
    最下端セル = 列 & "65536"
    With Worksheets("SSS")
        Set セル範囲 = .Range(.Range(上端セル), .Range(最下端セル).End(xlUp))
    End With
    For Each 各セル In セル範囲
        On Error Resume Next
        リスト.Add 各セル.Value, CStr(各セル.Value)
        If Err.Number = 0 Then
            Me.ComboBox7.AddItem 各セル.Value
        End If
        On Error GoTo 0
    Next

      '
    列 = "H"
    上端セル = 列 & "2"
    最下端セル = 列 & "65536"
    With Worksheets("SSS")
        Set セル範囲 = .Range(.Range(上端セル), .Range(最下端セル).End(xlUp))
    End With
    For Each 各セル In セル範囲
        On Error Resume Next
        リスト.Add 各セル.Value, CStr(各セル.Value)
        If Err.Number = 0 Then
            Me.ComboBox8.AddItem 各セル.Value
        End If
        On Error GoTo 0
    Next

      '
    列 = "I"
    上端セル = 列 & "2"
    最下端セル = 列 & "65536"
    With Worksheets("SSS")
        Set セル範囲 = .Range(.Range(上端セル), .Range(最下端セル).End(xlUp))
    End With
    For Each 各セル In セル範囲
        On Error Resume Next
        リスト.Add 各セル.Value, CStr(各セル.Value)
        If Err.Number = 0 Then
            Me.ComboBox9.AddItem 各セル.Value
        End If
        On Error GoTo 0
    Next

End Sub

 長いけど...

 Option Explicit

 Private dic As Object

 Private Sub UserForm_Initialize()
     Dim a, i As Long, ii As Long
     Set dic = CreateObject("Scripting.Dictionary")
     dic.CompareMode = 1
     a = Sheets("sss").Cells(1).CurrentRegion.Resize(, 10).Value
     For i = 2 To UBound(a, 1)
         For ii = 1 To UBound(a, 2)
             a(i, ii) = CStr(a(i, ii))
         Next
         If Not dic.exists(a(i, 1)) Then
             Set dic(a(i, 1)) = CreateObject("Scripting.Dictionary")
             dic(a(i, 1)).CompareMode = 1
         End If
         If Not dic(a(i, 1)).exists(a(i, 2)) Then
             Set dic(a(i, 1))(a(i, 2)) = CreateObject("Scripting.Dictionary")
             dic(a(i, 1))(a(i, 2)).CompareMode = 1
         End If
         If Not dic(a(i, 1))(a(i, 2)).exists(a(i, 3)) Then
             Set dic(a(i, 1))(a(i, 2))(a(i, 3)) = _
             CreateObject("Scripting.Dictionary")
             dic(a(i, 1))(a(i, 2))(a(i, 3)).CompareMode = 1
         End If
         If Not dic(a(i, 1))(a(i, 2))(a(i, 3)).exists(a(i, 4)) Then
             Set dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4)) = _
             CreateObject("Scripting.Dictionary")
             dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4)).CompareMode = 1
         End If
         If Not dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4)).exists(a(i, 5)) Then
             Set dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4))(a(i, 5)) = _
             CreateObject("Scripting.Dictionary")
             dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4))(a(i, 5)).CompareMode = 1
         End If
         If Not dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4))(a(i, 5)).exists(a(i, 6)) Then
             Set dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4))(a(i, 5))(a(i, 6)) = _
             CreateObject("Scripting.Dictionary")
             dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4))(a(i, 5))(a(i, 6)).CompareMode = 1
         End If
         If Not dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4))(a(i, 5))(a(i, 6)).exists(a(i, 7)) Then
             Set dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4))(a(i, 5))(a(i, 6))(a(i, 7)) = _
             CreateObject("Scripting.Dictionary")
             dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4))(a(i, 5))(a(i, 6))(a(i, 7)).CompareMode = 1
         End If
         If Not dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4))(a(i, 5))(a(i, 6))(a(i, 7)).exists(a(i, 8)) Then
             Set dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4))(a(i, 5))(a(i, 6))(a(i, 7))(a(i, 8)) = _
             CreateObject("Scripting.Dictionary")
             dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4))(a(i, 5))(a(i, 6))(a(i, 7))(a(i, 8)).CompareMode = 1
         End If
         If Not dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4))(a(i, 5))(a(i, 6))(a(i, 7))(a(i, 8)).exists(a(i, 9)) Then
             Set dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4))(a(i, 5))(a(i, 6))(a(i, 7))(a(i, 8))(a(i, 9)) = _
             CreateObject("System.Collections.ArrayList")
         End If
         dic(a(i, 1))(a(i, 2))(a(i, 3))(a(i, 4))(a(i, 5))(a(i, 6))(a(i, 7))(a(i, 8))(a(i, 9)).Add i
     Next
     Me.ComboBox1.List = dic.keys
 End Sub

 Private Sub ComboBox1_Change()
     ClearComb 2, 9
     With Me
         If .ComboBox1.ListIndex <> -1 Then
             .ComboBox2.List = dic(.ComboBox1.Value).keys
         End If
     End With
 End Sub

 Private Sub ComboBox2_Change()
     ClearComb 3, 9
     With Me
         If .ComboBox2.ListIndex <> -1 Then
             .ComboBox3.List = dic(.ComboBox1.Value)(.ComboBox2.Value).keys
         End If
     End With
 End Sub

 Private Sub ComboBox3_Change()
     ClearComb 4, 9
     With Me
         If .ComboBox3.ListIndex <> -1 Then
             .ComboBox4.List = dic(.ComboBox1.Value)(.ComboBox2.Value)(.ComboBox3.Value).keys
         End If
     End With
 End Sub

 Private Sub ComboBox4_Change()
     ClearComb 5, 9
     With Me
         If .ComboBox4.ListIndex <> -1 Then
             .ComboBox5.List = dic(.ComboBox1.Value)(.ComboBox2.Value)(.ComboBox3.Value)(.ComboBox4.Value).keys
         End If
     End With
 End Sub

 Private Sub ComboBox5_Change()
     ClearComb 6, 9
     With Me
         If .ComboBox5.ListIndex <> -1 Then
             .ComboBox6.List = dic(.ComboBox1.Value)(.ComboBox2.Value)(.ComboBox3.Value)(.ComboBox4.Value)(.ComboBox5.Value).keys
         End If
     End With
 End Sub

 Private Sub ComboBox6_Change()
     ClearComb 7, 9
     With Me
         If .ComboBox6.ListIndex <> -1 Then
             .ComboBox7.List = dic(.ComboBox1.Value)(.ComboBox2.Value)(.ComboBox3.Value)(.ComboBox4.Value)(.ComboBox5.Value)(.ComboBox6.Value).keys
         End If
     End With
 End Sub

 Private Sub ComboBox7_Change()
     ClearComb 8, 9
     With Me
         If .ComboBox7.ListIndex <> -1 Then
             .ComboBox8.List = dic(.ComboBox1.Value)(.ComboBox2.Value)(.ComboBox3.Value)(.ComboBox4.Value)(.ComboBox5.Value)(.ComboBox6.Value)(.ComboBox7.Value).keys
         End If
     End With
 End Sub

 Private Sub ComboBox8_Change()
    ClearComb 9, 9
    With Me
        If .ComboBox8.ListIndex <> -1 Then
             .ComboBox9.List = dic(.ComboBox1.Value)(.ComboBox2.Value)(.ComboBox3.Value)(.ComboBox4.Value)(.ComboBox5.Value)(.ComboBox6.Value)(.ComboBox7.Value)(.ComboBox8.Value).keys
        End If
    End With
 End Sub

 Private Sub ComboBox9_Change()
    With Me
        If .ComboBox9.ListIndex <> -1 Then
            MsgBox Join(dic(.ComboBox1.Value)(.ComboBox2.Value)(.ComboBox3.Value)(.ComboBox4.Value)(.ComboBox5.Value)(.ComboBox6.Value)(.ComboBox7.Value)(.ComboBox8.Value)(.ComboBox9.Value).ToArray, vbLf), , "Lacated in"
        End If
    End With
 End Sub

 Private Sub ClearComb(myStart, myEnd)
     Dim i As Long
     For i = myStart To myEnd
         Me.Controls("ComboBox" & i).Clear
     Next
 End Sub
（seiya） 2013/11/05(火) 13:50

seiyaさん
早速のご返答
ありがとうございます

また何かありましたら
よろしくお願いいたします
本当にありがとうございました
（KISS） 2013/11/05(火) 15:22

seiyaさん早速のお返答有難うございます
もう少し教えて頂けませんか

貴殿のマクロで抽出時して
Comboboxにデーターを入れまして
下記コードにてシートに張り付けた時
Comnbobox２～７までのデーターがセルに反映されないのは
なぜでしょうか
教えて頂けますか

Private Sub CommandButton1_Click()

  Dim ctrl As Control, txt1 As String, txt2 As String
    Dim ret As Integer

    For Each ctrl In Me.Controls
        Select Case ctrl.Name
            Case "ComboBox1", "ComboBox2", "ComboBox3", "ComboBox4", "ComboBox5", "ComboBox6", "ComboBox7", "ComboBox8"
                If Len(Trim$(ctrl.Text)) = 0 Then
                    txt1 = txt1 & ctrl.Name & vbLf
                Else
                    txt2 = txt2 & ctrl.Text & vbLf
                End If
            Case Else
        End Select
    Next

    If Len(txt1) > 0 Then
        MsgBox "以下の値を入力してください" & vbLf & txt1, vbExclamation
        Exit Sub
    Else
        ret = MsgBox("以下の値を入力します" & vbLf & txt2, vbOKCancel)
        If ret <> vbOK Then Exit Sub
    End If

Worksheets("SSS").Activate

    With ActiveSheet
        .Cells(.Cells.Rows.Count, "A").End(xlUp).Offset(1).Value = ComboBox1.Value
    End With
    ComboBox1.Value = ""

     With ActiveSheet
        .Cells(.Cells.Rows.Count, "B").End(xlUp).Offset(1).Value = ComboBox2.Value
    End With
    ComboBox2.Value = ""

     With ActiveSheet
        .Cells(.Cells.Rows.Count, "C").End(xlUp).Offset(1).Value = ComboBox3.Value
    End With
    ComboBox3.Value = ""

     With ActiveSheet
        .Cells(.Cells.Rows.Count, "D").End(xlUp).Offset(1).Value = ComboBox4.Value
    End With
    ComboBox4.Value = ""

     With ActiveSheet
        .Cells(.Cells.Rows.Count, "E").End(xlUp).Offset(1).Value = ComboBox5.Value
    End With
    ComboBox5.Value = ""

     With ActiveSheet
        .Cells(.Cells.Rows.Count, "F").End(xlUp).Offset(1).Value = ComboBox6.Value
    End With
    ComboBox6.Value = ""

      With ActiveSheet
        .Cells(.Cells.Rows.Count, "G").End(xlUp).Offset(1).Value = ComboBox7.Value
    End With
    ComboBox7.Value = ""

          With ActiveSheet
        .Cells(.Cells.Rows.Count, "H").End(xlUp).Offset(1).Value = ComboBox8.Value
    End With
    ComboBox8.Value = ""

          With ActiveSheet
        .Cells(.Cells.Rows.Count, "I").End(xlUp).Offset(1).Value = ComboBox9.Value
    End With
    ComboBox9.Value = ""

    Cells(Rows.Count, 1).End(xlUp).Select

    Intersect(Range("A:I"), Rows(ActiveCell.Row)).Interior.ColorIndex = 3

    ThisWorkbook.Save

End Sub

 ComboBox1.Value = "" の時点で
 ComboBox1_Change が反応して、ComboBox2 以降が全て空白になってしまう。

 全ての ComboBoxN.Value = "" を削除して
 最後に
 ClearComb 1, 9
 としてやればOK

 要約すると

 Private Sub CommandButton1_Click()
  Dim ctrl As Control, txt1 As String, txt2 As String
    Dim ret As Integer
    For Each ctrl In Me.Controls
        Select Case ctrl.Name
            Case "ComboBox1", "ComboBox2", "ComboBox3", "ComboBox4", "ComboBox5", "ComboBox6", "ComboBox7", "ComboBox8"
                If Len(Trim$(ctrl.Text)) = 0 Then
                    txt1 = txt1 & ctrl.Name & vbLf
                Else
                    txt2 = txt2 & ctrl.Text & vbLf
                End If
            Case Else
        End Select
    Next
    If Len(txt1) > 0 Then
        MsgBox "以下の値を入力してください" & vbLf & txt1, vbExclamation
        Exit Sub
    Else
        ret = MsgBox("以下の値を入力します" & vbLf & txt2, vbOKCancel)
        If ret <> vbOK Then Exit Sub
    End If
    With Worksheets("SSS").Cells(Rows.Count, 1).End(xlUp)(2).Resize(, 9)
        .Value = Array(ComboBox1.Value, ComboBox2.Value, ComboBox3.Value, ComboBox4.Value, _
                ComboBox5.Value, ComboBox6.Value, ComboBox7.Value, ComboBox8.Value, ComboBox9.Value)
        .Interior.ColorIndex = 3
    End With
    ClearComb 1, 9
    ThisWorkbook.Save
 End Sub
（seiya） 2013/11/05(火) 16:12

seiyaさん
早速のご回答ありがとうございました
早速やってみます

本当にありがとうございます
（KISS） 2013/11/05(火) 16:18

コメント返信：

[ 一覧(最新更新順) ]

[[20131105121455]] 『Comboboxリスト抽出』（KISS） ページの最後に飛ぶ

[[20131105121455]]　『Comboboxリスト抽出』（KISS）　ページの最後に飛ぶ