[[20081217082039]] 『3つ以上のコンボボックス連携について』(Voume11)  >>BOT

[ 初めての方へ | 一覧(最新更新順) | 全文検索 | 過去ログ ]

 

『3つ以上のコンボボックス連携について』(Voume11)

 はじめまして。
お世話になります。
VBAを1日前ぐらいにはじめた超初心者です。
 
色々と模索してたのですが、
コンボボックスのAddItemのmag2Combo2.xls例を用いて、
A列、B列、C列の内容というように、
3つ以上のコンボボックス連携を行いたいと思っています。
しかし、なかなか上手くいきません・・・。
 
コードは以下の通りです。(列3つを想定した時)
  
Option Explicit
Dim Level1(1000) As String, Level1C As Long
Dim sh3 As New Sheet3
 
' −−−−− −−−−− −−−−− −−−−− −−−−− −−−−−
' コンボボックス2つの連携例
'
' ユーザーフォームの構成は下の通り
'
' UserForm1
'    ComboBox1
'    ComboBox2
'    ComboBox3
'
' コンボボックスに登録するデータはSheet3 の1列 と2列 と3列にある
' −−−−− −−−−− −−−−− −−−−− −−−−− −−−−−
 
Private Sub ComboBox1_Change()
    ' ComboBox1 が変更されたときの処理
    Dim j As Long, r As Long, rmx As Long

    With UserForm1
        .ComboBox2.Text = ""   ' 前回選択されていた内容をクリア
        .ComboBox2.Clear       ' ComboBox2 に登録されている項目を全て削除する

        rmx = UFRowcount()
        For r = 2 To rmx
            If sh3.Cells(r, 1) = "" Then
                Exit For
            End If
            If sh3.Cells(r, 1) = .ComboBox1.Text Then
                ' 1列目がComboBox1 と等しい行の2列目をComboBox2 に登録する
                .ComboBox2.AddItem sh3.Cells(r, 2)
            End If
        Next r
    End With
     
End Sub
  
Private Sub ComboBox2_Change()
    ' ComboBox2 が変更されたときの処理
    Dim j As Long, r As Long, rmx As Long

    With UserForm1
        .ComboBox3.Text = ""   ' 前回選択されていた内容をクリア
        .ComboBox3.Clear       ' ComboBox3 に登録されている項目を全て削除する

        rmx = UFRowcount()
        For r = 2 To rmx
            If sh3.Cells(r, 2) = "" Then
                Exit For
            End If
            If sh3.Cells(r, 2) = .ComboBox2.Text Then
                ' 2列目がComboBox2 と等しい行の3列目をComboBox3 に登録する
                .ComboBox3.AddItem sh3.Cells(r, 3)
            End If
        Next r
    End With
   
End Sub
 
 
Private Sub UserForm_Initialize()
    ' UserForm1 初期化時の処理
    Dim r As Long, rmx As Long
    Level1C = 0
    rmx = UFRowcount()
    For r = 2 To rmx
        If sh3.Cells(r, 1) = ""  Then
            Exit For
        End If
        If UFSearchLevel1(sh3.Cells(r, 1)) = 0  Then
            ' 1列目の項目で登録されていないものをComboBox1 に登録する
            UserForm1.ComboBox1.AddItem sh3.Cells(r, 1)
           End If
    Next r
End Sub
 
 
Function UFSearchLevel1(key) As Integer
    ' 項目がすでに登録されていないか調べて、登録されていなかったら登録する
    ' UFSearchLevel1 = 0 なら登録されていない、UFSearchLevel1 = 1なら登録されている
    Dim i As Long
    UFSearchLevel1 = 0
    For i = 0 To Level1C
        If Level1(i) = key Then
            UFSearchLevel1 = 1
            Exit Function
        End If
    Next i
    Level1(Level1C) = key
    Level1C = Level1C + 1
End Function
 
Function UFRowcount() As Long
    ' データ(行)がどこまであるか調べる
    UFRowcount = sh3.Range("a65536").End(xlUp).Row + 1
End Function
 
 
 
 
単純にSUBプロシージャーをコピーして、
列の情報だけ変えれば出来ると思ったのですが、
上手く表現することはできますでしょうか?
御教示いただけると幸甚です。
 
よろしくお願いいたします。


 >なかなか上手くいきません・・・。
どの部分がどのように上手く行かないのでしょうか。
気が付いた限りでは、ComboBox2_Changeで、以下の部分。
 
If sh3.Cells(r, 2) = .ComboBox2.Text Then
 
ComboBox3へのAddItemで、想定していないデータも登録されていってしまう可能性。
ComboBox1_Change で「sh3.Cells(r, 1) = .ComboBox1.Text」に当てはまらないものも
          「sh3.Cells(r, 2) = .ComboBox2.Text」が当てはまってしまえば
コンボボックスのリストに追加されてしまいますよね。
 
(みやほりん)(-_∂)b

 Volume11です。
 返信誠に有難う御座います。

 ご説明不足で申し訳ありませんでした。

 今のコードでマクロを実行すると、 
 A列内の重複している項目を省いた状態で
 ComboBox1に表示されますが、B列、C列と連携はするものの、
 重複したものでもB列、C列に記入されているもの全てが表示され、
 ComboBox1同様に表示できません。

 表現したいことは、A列から重複しているものを省いた状態でComboBox1に表示し、
 その中の複数ある項目から一つ選ぶと、選んだA列内の項目と同じ行にあるB列の項目を、
 ComboBox1同様、ComboBox2に重複したものを省いた状態で表示させ、
 ComboBox3もそれに倣いといったように表現させたいと思っております。

<例>
ワークシート内

 A列      B列     C列      D列
 果物     長野産    梨       100円
 果物   長野産    りんご     50円
 果物   青森産    りんご     150円
 野菜   中国産    にんじん    30円
 野菜   アメリカ産  とうもろこし  20円

コンボボックス表示

 ComboBox1  果物を選択  ComboBox2  長野産を選択 ComboBox3 りんご選択 50円とポップアップにて表示
 果物      ⇒         長野産      ⇒       梨      ⇒
 野菜            中国産           りんご

という様に表現させたいと思っております。
御教示いただけると幸甚です。
よろしくお願いいたします。


 例として、投稿されたシートデータには、1行目が項目名であるという前提でよいですね?

 Sheet3には、

 A列      B列     C列      D列
 種別   産地    産物      単価
 果物     長野産    梨       100円
 果物   長野産    りんご     50円
 果物   青森産    りんご     150円
 野菜   中国産    にんじん    30円
 野菜   アメリカ産  とうもろこし  20円

 上記の項目名は、私が適当に命名しました。
 コードを見ると1行目が項目名として設定されているように思えます。
 だとしたら、例として投稿されたデータにも項目名を提示してください。

 もし、項目名がないデータなら、1行目には、項目名を付けてください。

 Excelでデータベース的なことを行う場合、項目名があった方が機能を使う上で便利ですから・・・。

 当該ユーザーフォームのモジュールに

 '====================================================================================
 Option Explicit
 Private sht3rng As Range
 Private Sub ComboBox1_Change()
    Dim tmprng As Range
    Dim crng As Range, rng As Range
    Dim myvalue As Variant
    ComboBox2.Clear
    If sht3rng.Row > 1 Then
       myvalue = ComboBox1.Text
       Set tmprng = sht3rng.Columns("j:j")
       Set rng = myspecialcells(tmprng.Offset(-1, 0).Resize(tmprng.Rows.Count + 1), _
                     tmprng, _
                     "=if(and(a2=""" & myvalue & """,countif(b$2:b2,b2)=1),1,"""")")
       If Not rng Is Nothing Then
          With ComboBox2
             For Each crng In rng.Offset(0, -8)
                .AddItem crng.Value
             Next
          End With
       End If
    End If
 End Sub
'====================================================================================
 Private Sub ComboBox2_Change()
    Dim tmprng As Range
    Dim crng As Range, rng As Range
    Dim myvalue1 As Variant
    Dim myvalue2 As Variant
    ComboBox3.Clear
    If sht3rng.Row > 1 Then
       myvalue1 = ComboBox1.Text
       myvalue2 = ComboBox2.Text
       Set tmprng = sht3rng.Columns("j:j")
       Set rng = myspecialcells(tmprng.Offset(-1, 0).Resize(tmprng.Rows.Count + 1), _
                     tmprng, _
                     "=if(and(a2=""" & myvalue1 & """,b2=""" & myvalue2 & """),1,"""")")
       If Not rng Is Nothing Then
          With ComboBox3
             For Each crng In rng.Offset(0, -7)
                .AddItem crng.Value
                .List(.ListCount - 1, 1) = crng.Row
             Next
          End With
       End If
    End If
 End Sub
 '====================================================================================
 Private Sub ComboBox3_Change()
    With ComboBox3
       .Visible = False
       DoEvents
       .Visible = True
       If .ListIndex >= 0 Then
          msgbox "種別   " & ComboBox1.Text & vbCrLf & _
                 "産地  " & ComboBox2.Text & vbCrLf & _
                 "産物  " & .Text & "   " & Worksheets("sheet3").Cells(.List(.ListIndex, 1), 4).Value
       End If
    End With
 End Sub
 '====================================================================================
 Private Sub UserForm_Initialize()
    Dim tmprng As Range
    Dim crng As Range, rng As Range
    With Worksheets("sheet3")
       Set sht3rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
    End With
    If sht3rng.Row > 1 Then
       Set tmprng = sht3rng.Columns("j:j")
       Set rng = myspecialcells(tmprng.Offset(-1, 0).Resize(tmprng.Rows.Count + 1), _
                     tmprng, _
                     "=if(countif(a$2:a2,a2)=1,1,"""")")
       With ComboBox1
          For Each crng In rng.Offset(0, -9)
             .AddItem crng.Value
          Next
       End With
    End If
 End Sub
 '====================================================================================
 Function myspecialcells(ByVal rng1 As Range, ByVal rng2 As Range, ByVal fml As String) As Range
    On Error Resume Next
    rng2.Formula = fml
    Set myspecialcells = Nothing
    Set myspecialcells = rng1.SpecialCells(xlCellTypeFormulas, xlNumbers)
    rng2.Formula = ""
    On Error GoTo 0
 End Function

 これで試してみてください。
 尚、データのあるシートSheet3のJ列を作業列として、プログラムが使っています。

 ichinose


ichinose様

 本件、御教示いただきまして誠に有難う御座います。
 非常に助かりました!
 これからコードひとつひとつじっくり勉強させていただきます。

(Volume11)


 Volume11です。
 また御質問があります。
 上のプログラムでコンボボックスをさらに増やして行きたい場合
(増やしたコンボボックスに関しては前回同様、重複削除)
 どのコードを変更、または加えればいいのでしょうか?
 下記のようなリストがあるとした場合、

 Trade 	         Item	Type	Size	Vender	Price
 Electrical 	Conduit	EMT	1-1/2''	GreybaR	5.5
 Electrical 	Conduit	EMT	1''	GreybaR	40
 Electrical 	Cable	Flexible	1'' 	GreybaR	8
 Electrical 	Conduit	RMT	1/2''	GreybaR	30
 Electrical 	Cable	Shielded 	3/4''	GreybaR	15
 Electrical 	Tray	Tee	9''	GreybaR	3
 Electrical 	Conduit	RMT	1''	GreybaR	4
 Electrical 	Cable	Flexible	1'' 	Rexel	100
 Electrical 	Conduit	RMT	1''	Rexel	10
 Electrical 	Cable	Shielded 	1''	Rexel	20
 Electrical 	Cable 	Tee	36''	Rexel	15
 Millwright	Anchor 	Chemical	45mm	Depot	20
 Millwright	Anchor 	Chemical	35mm	Depot	40
 Millwright	Anchor 	Normal	10mm	Depot	0.5
 Millwright	Measure	Self-Ret	5.5m	Home 	10
 Millwright	Anchor 	Chemical	35mm	Khama	40
 Millwright	Anchor 	Chemical	50mm	Lows	0.7
 Millwright	Anchor 	Normal	12mm	Lows	0.5
 Millwright	Anchor 	Chemical	35mm	Lows	50
 Pipefitter	Pipe	PVC	1/2''	Lows	4
 Pipefitter	Hose	Air 	3/4''	THose	100
 Pipefitter	Pipe	GalSteel	1/2''	THose	3
 Pipefitter	Pipe	Steam	3''	THose	10

 コンボボックス5つを使い連携させたいと思っております。
 いずれは5つ目のコンボボックスの値が変わったら、Private Sub ComboBox5_Change()内のコードを変更し、
 テキストボックス1に値段を表示させるようにする予定です。
 下記のコードをいじくっているのですが、ComboBox5にたどり着く前に、うまく表示されるものと、されないもので別れます・・・。原因が分かりません。
 コードは下記の通りです。

'====================================================================================

 Option Explicit
 Private sht3rng As Range
 Private Sub ComboBox1_Change()
    Dim tmprng As Range
    Dim crng As Range, rng As Range
    Dim myvalue As Variant
    ComboBox2.Clear
    If sht3rng.Row > 1 Then
       myvalue = ComboBox1.Text
       Set tmprng = sht3rng.Columns("j:j")
       Set rng = myspecialcells(tmprng.Offset(-1, 0).Resize(tmprng.Rows.Count + 1), _
                     tmprng, _
                     "=if(and(a2=""" & myvalue & """,countif(b$2:b2,b2)=1),1,"""")")
       If Not rng Is Nothing Then
          With ComboBox2
             For Each crng In rng.Offset(0, -8)
                .AddItem crng.Value
             Next
          End With
       End If
    End If
 End Sub
'====================================================================================
 Private Sub ComboBox2_Change()
    Dim tmprng As Range
    Dim crng As Range, rng As Range
    Dim myvalue1 As Variant
    Dim myvalue2 As Variant
    ComboBox3.Clear
    If sht3rng.Row > 1 Then
       myvalue1 = ComboBox1.Text
       myvalue2 = ComboBox2.Text
       Set tmprng = sht3rng.Columns("j:j")
       Set rng = myspecialcells(tmprng.Offset(-1, 0).Resize(tmprng.Rows.Count + 1), _
                     tmprng, _
                     "=if(and(a2=""" & myvalue1 & """,b2=""" & myvalue2 & """,countif(c$2:c2,c2)=1),1,"""")")
       If Not rng Is Nothing Then
          With ComboBox3
             For Each crng In rng.Offset(0, -7)
                .AddItem crng.Value
                .List(.ListCount - 1, 1) = crng.Row
             Next
          End With
       End If
    End If
 End Sub
 '====================================================================================
 Private Sub ComboBox3_Change()
    Dim tmprng As Range
    Dim crng As Range, rng As Range
    Dim myvalue1 As Variant
    Dim myvalue2 As Variant
    Dim myvalue3 As Variant
    ComboBox4.Clear
    If sht3rng.Row > 1 Then
       myvalue1 = ComboBox1.Text
       myvalue2 = ComboBox2.Text
       myvalue3 = ComboBox3.Text
       Set tmprng = sht3rng.Columns("j:j")
       Set rng = myspecialcells(tmprng.Offset(-1, 0).Resize(tmprng.Rows.Count + 1), _
                     tmprng, _
                     "=if(and(a2=""" & myvalue1 & """,b2=""" & myvalue2 & """,c2=""" & myvalue3 & """,countif(d$2:d2,d2)=1),1,"""")")
       If Not rng Is Nothing Then
          With ComboBox4
             For Each crng In rng.Offset(0, -6)
                .AddItem crng.Value
                .List(.ListCount - 1, 1) = crng.Row
             Next
          End With
       End If
    End If
 End Sub
  '====================================================================================
 Private Sub ComboBox4_Change()
    Dim tmprng As Range
    Dim crng As Range, rng As Range
    Dim myvalue1 As Variant
    Dim myvalue2 As Variant
    Dim myvalue3 As Variant
    Dim myvalue4 As Variant
    ComboBox5.Clear
    If sht3rng.Row > 1 Then
       myvalue1 = ComboBox1.Text
       myvalue2 = ComboBox2.Text
       myvalue3 = ComboBox3.Text
       myvalue4 = ComboBox4.Text
       Set tmprng = sht3rng.Columns("j:j")
       Set rng = myspecialcells(tmprng.Offset(-1, 0).Resize(tmprng.Rows.Count + 1), _
                     tmprng, _
                     "=if(and(a2=""" & myvalue1 & """,b2=""" & myvalue2 & """,c2=""" & myvalue3 & """,d2=""" & myvalue4 & """,countif(e$2:e2,e2)=1),1,"""")")
       If Not rng Is Nothing Then
          With ComboBox5
             For Each crng In rng.Offset(0, -5)
                .AddItem crng.Value
                .List(.ListCount - 1, 1) = crng.Row
             Next
          End With
       End If
    End If
 End Sub
 '====================================================================================
 Private Sub ComboBox5_Change()
    With ComboBox4
       .Visible = False
       DoEvents
       .Visible = True
       If .ListIndex >= 0 Then
          MsgBox "Trade   " & ComboBox1.Text & vbCrLf & _
                 "Item  " & ComboBox2.Text & vbCrLf & _
                 "Type  " & .Text & "   " & Worksheets("sheet3").Cells(.List(.ListIndex, 1), 4).Value
       End If
    End With
 End Sub

Private Sub CmbBtnClear_Click()

    ComboBox1.Value = ""
    ComboBox2.Value = ""
    ComboBox3.Value = ""
    ComboBox4.Value = ""

End Sub

Private Sub FormBtnClose_Click()

    Unload Me
End Sub

Private Sub MultiPage1_Change()

End Sub

 '====================================================================================
 Private Sub UserForm_Initialize()
    Dim tmprng As Range
    Dim crng As Range, rng As Range
    With Worksheets("sheet3")
       Set sht3rng = .Range("a2", .Cells(.Rows.Count, "a").End(xlUp))
    End With
    If sht3rng.Row > 1 Then
       Set tmprng = sht3rng.Columns("j:j")
       Set rng = myspecialcells(tmprng.Offset(-1, 0).Resize(tmprng.Rows.Count + 1), _
                     tmprng, _
                     "=if(countif(a$2:a2,a2)=1,1,"""")")
       With ComboBox1
          For Each crng In rng.Offset(0, -9)
             .AddItem crng.Value
          Next
       End With
    End If
 End Sub
 '====================================================================================
 Function myspecialcells(ByVal rng1 As Range, ByVal rng2 As Range, ByVal fml As String) As Range
    On Error Resume Next
    rng2.Formula = fml
    Set myspecialcells = Nothing
    Set myspecialcells = rng1.SpecialCells(xlCellTypeFormulas, xlNumbers)
    rng2.Formula = ""
    On Error GoTo 0
 End Function

 どなたか御教示頂けないでしょうか?
 よろしくお願い申し上げます。
 (Volume11)

 >うまく表示されるものと、されないもので別れます・・・。
 この時の「上手く表示されない物」として
 どの様な組み合わせで選ぶと上手く表示されないのか
 書いてあると良いと思います。

 こちらでその組み合わせを見つける必要が無くなりますので。

 一つは見つけました。
 再度ご提示のサンプルで以下の組み合わせの時、上手く表示されません。
 Pipefitter - Hose - Air ・・・・

 思いますに「COUNTIF」部分がおかしいと思います。
 Houseは全体を通して1回しか出てきません。
 Airも同様です。
 その他の項目も、ここまでは
  それまでに選んできたグループの外に重複がない
 ですね。

 ですから、
  それまでの項目が一致して「a2=""" & myvalue1 & """,b2=""" & myvalue2 & """,・・・・」
  次の項目の内上から確認し初めて出てくるもの「countif(c$2:c2,c2)=1)」
 が次のコンボボックスに表示されれば良いですが
 D列の項目はそうはいきません。

 Pipefitter - Hose - Air と選んだ時に、22行目の「3/4''」が
 次のコンボボックスに表示されたいですが、D列だけをみると6行目に
 一度「3/4''」が有るので、22行目のCOUNTIFの戻り値は「2」と成り
 この行が対象から外れてしまいます。

 ですので、COUNTIF関数ではなくSUMPRODUCT関数で
  これまで選んできたグループの中で、初めて出てくる物は
 と言う形にするのが良いのではないかと思います。
SUMPRODUCT((a$2:a2=""" & myvalue1 & """)*(b$2:b2=""" & myvalue2 & """)*(c$2:c2=c2))=1
 の様に。

 それから、ComboBox5に表示させる内容を絞り込むときにも
 重複を除いていますが ここは重複が有った場合は
 そのまま表示させるのが良いと思いますよ。

 もしも重複が有った場合は、直す必要が有るのだと思いますので。

 (HANA)

 ごめんなさい。私のコードには、確かにバグがありそうです。先週から、ちょっと入院してまして、
 昨日退院してきました。投稿後、気が付きましたが、もう遅かった・・・・。

 Dictionaryオブジェクトを使ったほうがよかったかなあ。

 一週間も経ってしまい、病み上がりなので、
 申し訳ないですが、HANAさんよろしくお願いします。

 ichinose


 えぇっ、ichinoseさん 大丈夫ですか?
 (病み上がりだから「!」が無いのかな?)
 これから寒さ本番ですからね。
 お早い目で体調を戻して下さいね。
 Volume11さんの為にも。。。。

 (HANA)

HANA様

 返信が遅れまして申し訳ありません!
 御教示いただきまして誠に有難う御座いました。
 次回より質問の仕方についても気をつけてまいりたいと思います。

 御丁寧な解説が分かりやすく、非常に勉強になりました!
 また、もし不明なことが出てきた時には、
 御教示いただけると幸甚です。
 上記の方法でトライさせていただきます!

ichinose様

 御体調の方は、大丈夫でしょうか!?!?
 病み上がりなのにも関わらず、本件に関してフォローしていただきまして、
 本当に有難う御座います。
 色々とお気遣いしていただき、申し訳ありません。 
 御無理はなされず、お体には御自愛ください。

 (Volume11)


 こんにちは。

 ComboBoxの絞り込みというか 連動表示は興味深い問題で、
 このスレッドが始まったときにはずっとROMさせていただいていました。

 > Dictionaryオブジェクトを使ったほうがよかったかなあ。
 Dictionary案でいくと、どのようになるのか、ちょっと試行錯誤してみました。

 まず、簡単な例として ichinoseさんのサンプルデータのうち2列だけを取り出して、
    A        B
 1 分類      産物
 2 果物      梨
 3 果物      りんご
 4 果物      りんご
 5 野菜      にんじん
 6 野菜      とうもろこし

 これを ComboBox1のListに 
      果物
      野菜
 とリストし、果物が選択されたら {梨, りんご} と、
             野菜が選択されたら {にんじん、とうもろこし} と別のComboBoxに表示する
 までを考えてみました。

 一番最初に思いつく方法は、単純に
  dictionaryをひとつ用意して 
  dic("果物") = dic("果物") & "," & "梨"
  dic("果物") = dic("果物") & "," & "りんご"
  ...
 とキー「果物」のアイテムに 産物(B列)を集合させていくことですが、この方法ですと
 アイテム配列内の要素の重複チェックをしていませんので、結果は:

      key       Item
   dic("果物") = {梨, りんご, りんご}
   dic("野菜") = {にんじん, とうもろこし}

 と、このばあい「りんご」が重複してリストされてしまいます。

 そこで、Items配列も 別のDictionaryをあてがうことにより、Itemに重複がないような
 方法を考えます。
 ...と、言葉にすると、なんのことか分からないので、以下、図を交えながら、
 考え方を紹介します。
 先ほどのデータを上から順に 以下のような判定で複数の辞書に登録していきます。

 1つ目のデータ: 分類「果物」  産物「梨」
  --------  dic(1)に「果物」は登録されているか ?       
          まだなので  dic(1)のkeyに「果物」を登録。   
          そして 分類「果物」用のSubItemを管理するdic(2)を作り、
                 ここに 産物「梨」を登録する。 (下図)        

   ┃        ┃       ┃        ┃                              
   ┃果物(2) ┃       ┃梨      ┃                              
   ┗━━━━┛       ┗━━━━┛                             
     dic(1)             dic(2)          ★ この時点で dic(1)のkey は「果物」があり、
                                        そのItemには(梨という産物名ではなく)[2]という参照辞書番号が
                                        エントリされている

 2つめのデータ: 「果物」の「りんご」
  -----------   dic(1)に「果物」は登録されているか  ?           
    すでにあるので dic(1)「果物」のSubItemを管理するdic番号 (2) に   
                      りんご を登録する。   

   ┃        ┃       ┃りんご  ┃                              
   ┃果物(2) ┃       ┃梨      ┃                              
   ┗━━━━┛       ┗━━━━┛                             
     dic(1)             dic(2)                                

 3つめのデータ :「果物」の「りんご」
 -------  dic(1)に「果物」は登録されているか  ?          
  すでにあるので  
   dic(1)「果物」のSubItemを管理するdic番号 (2) に   
                          りんご を登録する。   

     ┃        ┃       ┃りんご  ┃  ★このとき dic(2)にすでに「りんご」は登録されている   
     ┃果物(2) ┃       ┃梨      ┃    ので、dic(2) のkeyは{梨、りんご} の2つのままである。        
     ┗━━━━┛       ┗━━━━┛                                               
       dic(1)             dic(2)                                                   

 4つめのデータ :「野菜」の「にんじん」
  --------   dic(1)に「野菜」は登録されているか ?       
       まだなので dic(1)のkeyに「野菜」を登録。   
                    同時に 「野菜」用のSubItemを管理するdic(3)を作る        
                                       dic(3)に「にんじん」を登録。    
     ┃野菜(3) ┃       ┃りんご  ┃    ┃        ┃             
     ┃果物(2) ┃       ┃梨      ┃    ┃にんじん┃             
     ┗━━━━┛       ┗━━━━┛    ┗━━━━┛             
       dic(1)             dic(2)          dic(3)                 

 最後のデータ ---「野菜」の「とうもろこし」
  -----  dic(1)に「野菜」は登録されているか ?       
     すでにあるので      
      dic(1)「野菜」のSubItemを管理するdic番号 (3) に
                                       とうもろこし を登録する。 
     ┃野菜(3) ┃       ┃りんご  ┃    ┃もろこし┃             
     ┃果物(2) ┃       ┃梨      ┃    ┃にんじん┃             
     ┗━━━━┛       ┗━━━━┛    ┗━━━━┛             
       dic(1)             dic(2)          dic(3)                 

 5行を読み込んだ結果はこうなります:
   dic(1)「果物」= dic(2) {梨, りんご } 
   dic(1)「野菜」= dic(3) {にんじん, とうもろこし } 

 こんどは りんごの重複が回避できました。

 つづく  (kanabun)


 こんどは 先ほどのサンプルデータ表↓全体を

 1 分類      産物        産地       単価
 2 果物      梨          長野産      100
 3 果物      りんご      長野産      130
 4 果物      りんご      青森産      150
 5 野菜      にんじん    中国産       20
 6 野菜   とうもろこし   アメリカ産   30

 ComboBox1 →ComboBox2 →ComboBox3 と TextBoxに絞り込み連動表示させることを
 考えてみます。

 ▼最初のデータ 分類「果物」  産物「梨」 産地「長野産」単価「100」
 --------  dic(1)に「果物」は登録されているか ?       
   まだなので  dic(1)のkeyに「果物」を登録。   
   同時に 「果物」用のSubItemを管理するdic(2)を作る。
                     産物「梨」用の 産地dic はまだ無いので dic(3)を追加し、
                                  ここに「長野」100 を登録する
  ┃        ┃       ┃        ┃     ┃            ┃           
  ┃果物(2) ┃       ┃梨(3)   ┃     ┃長野(100)   ┃           
  ┗━━━━┛       ┗━━━━┛     ┗━━━━━━┛           
    dic(1)             dic(2)           dic(3)                   

 ▼2つ目のデータ
 「果物」        「りんご」  「長野産」      「130」
 ----- dic(1)に「果物」はすでに登録済なので その産物用番号(2)を得る。
    dic(2) に「りんご」を登録する。
     「りんご」の産地番号は未登録なので あらたにdic(4)を作り、ここに「長野」を登録する。

  ┃        ┃       ┃りんご(4) ┃     ┃            ┃     ┃            ┃             
  ┃果物(2) ┃       ┃梨(3)     ┃     ┃長野(100)   ┃     ┃長野(130)   ┃             
  ┗━━━━┛       ┗━━━━━┛     ┗━━━━━━┛     ┗━━━━━━┛             
    dic(1)             dic(2)              dic(3)               dic(4)                    

 ▼3つ目のデータ
        「果物」        「りんご」  「青森産」      「150」
 ----- dic(1)に「果物」はすでに登録済なので その産物用番号(2)を得る。
    dic(2) に「りんご」を登録する(★すでに「りんご」はあるので上書きされる)。
     「りんご」の産地番号は(4)なので dic(4)に「青森」を登録する。

  ┃        ┃       ┃りんご(4) ┃     ┃            ┃     ┃青森(150)   ┃             
  ┃果物(2) ┃       ┃梨(3)     ┃     ┃長野(100)   ┃     ┃長野(130)   ┃             
  ┗━━━━┛       ┗━━━━━┛     ┗━━━━━━┛     ┗━━━━━━┛             
    dic(1)             dic(2)              dic(3)               dic(4)                    

 ▼4つ目のデータ     「野菜」  「にんじん」        「中国産」  「20」
 --------  dic(1)に「野菜」は未登録なので       
   dic(1)のkeyに「野菜」を登録。野菜の産物用dic(5) を新たに作り、   
               ここに「にんじん」を登録。「にんじん」の産地用dic(6)を新たに作り
               ここに 「中国(50)」を登録。 

  ┃野菜(5) ┃       ┃りんご(4) ┃     ┃            ┃     ┃青森(150)   ┃             
  ┃果物(2) ┃       ┃梨(3)     ┃     ┃長野(100)   ┃     ┃長野(130)   ┃             
  ┗━━━━┛       ┗━━━━━┛     ┗━━━━━━┛     ┗━━━━━━┛             
    dic(1)             dic(2)              dic(3)               dic(4)                    

                     ┃            ┃      ┃            ┃                                  
                     ┃にんじん(6) ┃      ┃中国(50)    ┃                                  
                     ┗━━━━━━┛      ┗━━━━━━┛                                  
                       dic(5)                 dic(6)                                         

 ▼最後のつ目のデータ目    「野菜」        「とうもろこし」        「アメリカ産」      「30」
 ------- dic(1)の「野菜」の産物用dic番号は(5)なので
                「とうもろこし」をdic(5)に追加。
                「とうもろこし」は初出なのでこれの「産地」用のdic(7)を作成。
                                              dic(7)に アメリカ産 30 を登録。

  ┃野菜(5) ┃       ┃りんご(4) ┃     ┃            ┃     ┃青森(150)   ┃             
  ┃果物(2) ┃       ┃梨(3)     ┃     ┃長野(100)   ┃     ┃長野(130)   ┃             
  ┗━━━━┛       ┗━━━━━┛     ┗━━━━━━┛     ┗━━━━━━┛             
    dic(1)             dic(2)              dic(3)               dic(4)                    

                     ┃もろこし(7) ┃      ┃            ┃   ┃            ┃            
                     ┃にんじん(6) ┃      ┃中国(50)    ┃   ┃アメリカ(30)┃            
                     ┗━━━━━━┛      ┗━━━━━━┛   ┗━━━━━━┛            
                       dic(5)                 dic(6)             dic(7)                   

 UserFormの表示の流れですが
 ComboBox1 には dic(1)の KeysとSubItems を 以下のようにリストしておく。
    果物   2
    野菜   5
              (リストの2列目は非表示)

 ComboBox1で_Click() があれば、選択リストの2列目の番号に対応する
 dicを ComboBox2のリストに表示する。
 (例えば、ComboBox1の「果物」が選択されたら、dic番号は(2)なので、
  ComboBox2 には dic(2)を以下のように出力する。
     梨      3
     りんご  4
              (リストの2列目は非表示)

 ComboBox2 で りんご がクリックされたら、ComboBox3のリストを
 dic(4)内容によって更新すればよい。
   長野産     130
   青森産     150
              (リストの2列目は非表示)

 ComboBox3 で 「青森産」が選択されたら、テキストボックスには
  ComboBox3のリストの2列目の値「150」を表示すればよい。

 と、だいたいこんな流れです

 つづく (kanabun)


 上の考えに基づき (Volume11) さんの表データ
  Trade 	         Item	Type	Size	Vender	Price
  Electrical 	Conduit	EMT	1-1/2''	GreybaR	5.5
  Electrical 	Conduit	EMT	1''	GreybaR	40
  Electrical 	Cable	Flexible	1'' 	GreybaR	8
  Electrical 	Conduit	RMT	1/2''	GreybaR	30
  Electrical 	Cable	Shielded 	3/4''	GreybaR	15
  Electrical 	Tray	Tee	9''	GreybaR	3
  Electrical 	Conduit	RMT	1''	GreybaR	4
  Electrical 	Cable	Flexible	1'' 	Rexel	100
  Electrical 	Conduit	RMT	1''	Rexel	10
  Electrical 	Cable	Shielded 	1''	Rexel	20
  Electrical 	Cable 	Tee	36''	Rexel	15
  Millwright	Anchor 	Chemical	45mm	Depot	20
  Millwright	Anchor 	Chemical	35mm	Depot	40
  Millwright	Anchor 	Normal	10mm	Depot	0.5
  Millwright	Measure	Self-Ret	5.5m	Home 	10
  Millwright	Anchor 	Chemical	35mm	Khama	40
  Millwright	Anchor 	Chemical	50mm	Lows	0.7
  Millwright	Anchor 	Normal	12mm	Lows	0.5
  Millwright	Anchor 	Chemical	35mm	Lows	50
  Pipefitter	Pipe	PVC	1/2''	Lows	4
  Pipefitter	Hose	Air 	3/4''	THose	100
  Pipefitter	Pipe	GalSteel	1/2''	THose	3
  Pipefitter	Pipe	Steam	3''	THose	10

 を対象にコード化するとこんな風です。
 なお、

 > コンボボックス5つを使い連携させたいと思っております。
 ということですが、便宜上 ComboBoxは すべて ListBoxに代えてあります。

 '◆Microsoft Scripting Runtime への参照設定が必要です
 '-----------------------------------------------------------
 Option Explicit

 Private dic() As Scripting.Dictionary
 Private dicMax As Long
 Private Const ComboCount = 5  'ListBoxの数

 Private Sub UserForm_Initialize()  
    Dim v, sKey As String
    Dim i As Long, j As Long, k As Long, n As Long

    With Worksheets("Sheet2") '◆ 対象シート 要変更
        v = .Range("A2", .Cells(.Rows.Count, 1).End(xlUp)). _
              Resize(, ComboCount + 1).Value
    End With

    dicMax = UBound(v) * 2 ' Dictionaryは いくつ要るか判らないので とりあえず レコード数*2 程度としています
    ReDim dic(1 To dicMax)
    Set dic(1) = New Scripting.Dictionary
    k = 1
    For i = 1 To UBound(v)
        n = 1
        For j = 1 To ComboCount - 1
            If Not IsEmpty(v(i, j)) Then sKey = v(i, j)
            If Not dic(n).Exists(sKey) Then
                k = k + 1
                dic(n)(sKey) = k       '★ItemにkeySting用dic番号
                Set dic(k) = New Scripting.Dictionary
                n = k
            Else
                n = dic(n)(sKey)
            End If
        Next
        dic(n).Item(v(i, ComboCount)) = v(i, ComboCount + 1)
    Next
    dicMax = k
    Debug.Print "dic.Count= "; k
    With ListBox1
        .List = Application.Transpose(Array(dic(1).Keys, dic(1).Items))
        .ListIndex = 0
    End With
 End Sub
 '-----------------------------------------------------------
 Private Sub UserForm_QueryClose(Cancel As Integer, CloseMode As Integer)
    Dim i As Long
    For i = dicMax To 1 Step -1
        Set dic(i) = Nothing
    Next
 End Sub
 '-----------------------------------------------------------
 Private Sub ListBox1_Change()
    ComboBox_Update ListBox1, ListBox2
 End Sub

 Private Sub ListBox2_Change()
    ComboBox_Update ListBox2, ListBox3
 End Sub

 Private Sub ListBox3_Change()
    ComboBox_Update ListBox3, ListBox4
 End Sub

 Private Sub ListBox4_Change()
    ComboBox_Update ListBox4, ListBox5
 End Sub
 '-----------------------------------------------------------
 ' Private Sub ComboBox_Update(ByVal List1 As MSForms.ComboBox, _
                             ByVal List2 As MSForms.ComboBox)     ComboBoxのときは 下を こちらに代えてください

 Private Sub ComboBox_Update(ByVal List1 As MSForms.ListBox, _
                             ByVal List2 As MSForms.ListBox)
    Dim idx As Long
    Dim n As Long, i As Long
    Dim v
    idx = List1.ListIndex
    If idx < 0 Then Exit Sub
    n = List1.List(idx, 1)
    With List2
        i = 0
        .Clear
        For Each v In dic(n).Keys
            .AddItem v
            .List(i, 1) = dic(n).Item(v)
            i = i + 1
        Next
        .ListIndex = 0
    End With

 End Sub
 '-----------------------------------------------------------
 Private Sub ListBox5_Change()
    Dim idx As Long
    With ListBox5
        idx = .ListIndex
        If idx < 0 Then Exit Sub
        TextBox1.Text = .List(idx, 1)
    End With
 End Sub

 '----------------------
 とりあえず今までのところこんなコードですが、
 こうしたほうがよいとか ありましたら コメントください   m(__)m

  (kanabun) 2009-06-14 0:40頃


 kanabun様

 お返事が大変遅れまして申し訳ありません。
 ご丁寧なご説明をしていただきまして、誠に有難うございます。
 考え方のステップが非常に分かり易かったです。
 Dictionaryの使い方が未だ勉強不足なので、
 コードをじっくり消化させていただきたく思います。
 ご教示有難うございました。

 Volume11 2010-01-09 USA EST16:50頃

 勉強中との事ですし、折角書いたので参考にアップしてみます。
 ComboBoxを増やすのを簡単に書いてみました。

  Private myComb As New Collection
  Private myRng As Range

  Private Sub UserForm_Initialize()
  Dim i As Long, tbl As Variant
  For i = 1 To 5
    myComb.Add Me.Controls("ComboBox" & i)
  Next i
  With Worksheets("Sheet1").Range("A1").CurrentRegion
    Set myRng = .Offset(1).Resize(.Rows.Count - 1)
  End With
  With CreateObject("Scripting.Dictionary")
    tbl = myRng.Resize(, 1).Value
    For i = 1 To UBound(tbl)
      If Not .Exists(tbl(i, 1)) Then
        .Add tbl(i, 1), ""
      End If
    Next i
    Me.ComboBox1.List = .keys
  End With
  End Sub

  Private Sub ComboBox1_Change()
  SetList 1
  End Sub

  Private Sub ComboBox2_Change()
  SetList 2
  End Sub

  Private Sub ComboBox3_Change()
  SetList 3
  End Sub

  Private Sub ComboBox4_Change()
  SetList 4
  End Sub

  Private Sub ComboBox5_Change()
  SetList 5 '必要無いけど・・・
  End Sub

  Private Sub SetList(CntNum As Long)
  Dim tbl1 As Variant, tbl2 As Variant, i As Long, myKey As String
  If CntNum >= myComb.Count Then Exit Sub
  For i = CntNum + 1 To myComb.Count
    myComb(i).Clear
  Next i
  tbl1 = myRng.Resize(, CntNum).Value
  tbl2 = myRng.Offset(, CntNum).Resize(, 1).Value
  For i = 1 To CntNum
    myKey = myKey & vbTab & myComb(i).Value
  Next i
  With CreateObject("Scripting.Dictionary")
    For i = 1 To UBound(tbl1)
      If Join(Application.WorksheetFunction.Index(tbl1, i, 0), vbTab) = Mid(myKey, 2) Then
        If Not .Exists(tbl2(i, 1)) Then
          .Add tbl2(i, 1), ""
        End If
      End If
    Next i
    myComb(CntNum + 1).List = .keys
  End With
  End Sub

 (momo)

 ろくでなし業者のスパム広告が書き込まれていたので広告を削除

コメント返信:

[ 一覧(最新更新順) ]


YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki. Modified by kazu.