Results of 1 - 1 of about 48828 for A�����������������������... (0.010 sec.)
- [[20131105121455]]
- #score: 1420
- @digest: 34164a1ce7f8a1c309ce28b634954333
- @id: 63776
- @mdate: 2013-11-05T07:18:27Z
- @size: 15381
- @type: text/plain
- #keywords: 端セ (93315), 囲on (60491), clearcomb (59024), combobox6 (44480), combobox7 (40291), combobox5 (36299), 下端 (35615), ル), (34632), combobox8 (34092), 列& (31143), combobox4 (29271), 出co (28859), combobox9 (28321), ル). (27997), comparemode (25212), ト抽 (25069), ルin (24107), combobox3 (22621), ル. (22184), 各セ (18173), 上端 (18067), combobox2 (17286), txt1 (12693), combobox1 (12134), 最下 (11168), txt2 (10115), 囲= (9229), ト. (6884), sss (6416), additem (6410), listindex (6135), ル= (5311)
- 『Comboboxリスト抽出』（KISS）
Ver2010 Win7 いつも大変お世話になっております 下記の件大変お手数ですがご教授頂けたら幸いです 以前に検索用で教えていただいたのですが 教えて頂いたのを入力用に使おうと思ったのですが 上手にいかなくて大変申し訳ございません 現状ですと リストがすべて出てしまう為 フィルターを掛けたいと思ってます Combobox1〜9配置してまして Combobox1を選択したときConbobox1に関連したCombobox2リスト抽出 Combobox2を選択したときConbobox2に関連したCombobox3リスト抽出 Combobox3を選択したときConbobox3に関連したCombobox4リスト抽出 Combobox4を選択したときConbobox4に関連したCombobox5リスト抽出 Combobox5を選択したときConbobox5に関連したCombobox6リスト抽出 Combobox6を選択したときConbobox6に関連したCombobox7リスト抽出 上記の様なフィルタを掛けたいのですがどの様にすればよいのでしょうか よろしくお願いいたします 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にデーターを入れまして 下記コードにてシートに張り付けた時 Comnbobox2〜7までのデーターがセルに反映されないのは なぜでしょうか 教えて頂けますか 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... - http://www.excel.studio-kazu.jp/wiki/kazuwiki/201311/20131105121455.txt - [detail] - similar
PREV
NEXT
Powered by Hyper Estraier 1.4.13, with 97012 documents and 608132 words.
訪問者：