Excel VBAで抽出コンボって無理ですか？

質問

簡単な発注システムを作成しようとしています。
Accessはあまり詳しくないので、できればExcel VBAで作りたいと思います。

その中で、２つのコンボボックスおよびをユーザーフォーム内に配置し、片方には発注先（Combo1）を、もう片方には担当者名（Combo2）を選択入力したいと考えています。
１つの発注先に対して複数の担当者がいる場合、別シートに下のようなフィールドを持つテーブルを用意しました。
発注先　　担当者
Ａ社　　　佐藤
Ａ社　　　田中
Ｂ社　　　渡辺
Ｂ社　　　後藤
Ｂ社　　　鈴木
Ｃ社　　　中村

ここで、発注先としてＢ社を選択した場合、Combo2からは渡辺,後藤,鈴木だけが選択できるようにしたいのですがこのような処理はExcelでは無理でしょうか？
やはりAccessでクエリを使って処理した方が良いでしょうか？
どなたかご指南願います。Excel2002を使用しています。

回答No.4

kazuhiko5681 · ベストアンサー

早速ご質問にお答えしたいと思います。
私の作成ミスで申し訳ございませんでした。前回のコードに記述ミスがありました。修正マクロを作ってみましたので、参考にしてみて下さい。

Private Sub Cmb1_Exit(ByVal Cancel As MSForms.ReturnBoolean)

Dim myCell As String
Dim myRange As Range
Dim myRow As Integer
Dim myClm As Integer
Dim i As Integer

Me.Cmb2.Clear
myCell = ActiveWorkbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Address
Set myRange = ActiveWorkbook.Worksheets(1).Range("A1:" & myCell).Find(Me.Cmb1.Text, lookat:=xlWhole)
If myRange Is Nothing Then
MsgBox "発注先の入力が正しくありません。", vbOKOnly + vbCritical, "入　力　エ　ラ　ー"
Me.Cmb1.Text = "": Cancel = True: Exit Sub
Else
myRow = myRange.Row
End If

myClm = ActiveWorkbook.Worksheets(1).Cells(myRow, Columns.Count).End(xlToLeft).Column
For i = 2 To myClm
Me.Cmb2.AddItem (ActiveWorkbook.Worksheets(1).Cells(myRow, i).Value)
Next i

これで、あなた様が問題と思われた内容がすべて訂正され、あなた様が思われているような動作をすると思います。

また、不都合な点がございましたらお知らせ下さい。

お礼

kazuhiko5681様、大変丁寧な回答をありがとうございました。VBAはかじり始めたばかりでまだ十分理解できていませんが、ご回答いただいた例を参考にして、勉強しながらがんばりたいと思います。

本当にありがとうございました。

回答No.3

kazuhiko5681

はじめまして。あなた様のやりたいことを実現することができるサンプルマクロを作ってみました。次の方法で操作してみて下さい。

１.新規ブックを立ち上げる。
２.Sheet1のＡ２にＡ社・Ｂ２に佐藤・Ｃ２に田中Ａ３にＢ社Ｂ３に渡辺・Ｃ３に後藤・Ｄ３に鈴木というようにＡ列に発注先・Ｂ列～Ｃ列・Ｄ列・・に担当者名を入力する表を作る。
３.ＶＢＥ画面を立ち上げ、ユーザーフォームを追加し、フォーム上にコンボボックスを２個配置し、プロパティウインドウからオブジェクト名をそれぞれCmb1・Cmb2と変更する。
４.フォームをダブルクリックしてフォームモジュールを表示させ、そこに下記のコードをコピー・ペーストする。

Private Sub Cmb1_Exit(ByVal Cancel As MSForms.ReturnBoolean)

Dim myCell As String
Dim myRange As Range
Dim myRow As Integer
Dim myClm As Integer
Dim i As Integer

myCell = ActiveWorkbook.Worksheets(1).Cells(Rows.Count, 1).End(xlUp).Address
Set myRange = ActiveWorkbook.Worksheets(1).Range("A1:" & myCell).Find(Me.Cmb1.Text, lookat:=xlWhole)
If myRange Is Nothing Then
MsgBox "発注先の入力が正しくありません。", vbOKOnly + vbCritical, "入　力　エ　ラ　ー"
Me.Cmb1.Text = "": Cancel = True
Else
myRow = myRange.Row
End If

myClm = ActiveWorkbook.Worksheets(1).Cells(myRow, Columns.Count).End(xlToLeft).Column
For i = 2 To myClm
Me.Cmb2.AddItem (ActiveWorkbook.Worksheets(1).Cells(myRow, i).Value)
Next i

End Sub

５.Ｆ５キーを押してフォームを立ち上げ、Cmb1に発注先を入力し、Cmb2にフォーカスを移す。
６.Cmb2の右にある▼ボタンをクリックする。

あなた様のやりたいことが実現しているはずです。

もし違っていたり、不都合なことがありましたら、ご遠慮なくお知らせ下さい。私でよろしければ、あなた様のやられたいことが実現するまで一緒に考えていきたいと思います。

お礼

kazuhiko5681様、素晴らしい回答をありがとうございます。確認したところ私の思い通りの動作であり、感激しています！
ところで欲を出して申し訳ないのですが、入力エラー処理の後エラーで止まってしまうのですが、これはExit Subで抜けて構わないでしょうかね？
あと、Cmb1のフォーカスを解除するとCmb2のリストが作成されるので、Ａ社を選んだ後、一旦Cmb1のフォーカスを外し、今度はＢ社を選んだ場合、Ａ社の担当者とＢ社の担当者が重複してCmb2のリストに登録されてしまいます。これは・・・Cmb1のChangeイベントを受けてCmb2のリストをその都度消去すればいいと思うのですが、
cmb2.Rowsource=""
とかやっても消えてくれません。
無知ですみませんが適切な処理方法をご教授願いませんでしょうか？
よろしくお願いします。

回答No.2

nishi6

Sheet1で何か処理を行い、ユーザーフォームを表示し、質問の表はSheet2にあるとします。同一のシートであっても問題はないでしょう。

Sheet2のA1から、質問にあるデータを入力しておきます。
A列は発注先、B列は担当者、データは2行目からです。
発注先 担当者
Ａ社 佐藤
Ａ社 田中
Ｂ社 渡辺
Ｂ社 後藤
Ｂ社 鈴木
Ｃ社 中村

Sheet1に起動用のボタンを作ります。
Private Sub CommandButton1_Click()
　　UserForm1.Show
End Sub

ユーザーファーム(UserForm1)にコンボボックスを２つ貼り付けます。Combo1(発注先用)とCombo2(担当者用)

ほとんど似たコードですが、下のコードをユーザーフォームのコードウインドウに貼り付けます。
説明が面倒になるので、AdvancedFilterは何もオプションをつけずに使っています。
データを絞り込む手段はたくさんあるでしょう。(Excel2000です)

ここから
↓
Dim ws2 As Worksheet '発注先と担当者が登録されたワークシート
Dim rg As Range 'セル

Private Sub UserForm_Initialize()
　　Set ws2 = Worksheets("Sheet2")
　　Application.ScreenUpdating = False
　　'コンボボックスのリストを抽出(発注先)
　　ws2.UsedRange.Columns(1).AdvancedFilter xlFilterInPlace, , , True

　　With Combo1
　　　　.Clear
　　　　For Each rg In ws2.UsedRange.Columns(1).SpecialCells(xlCellTypeVisible)
　　　　　　If rg.Row <> 1 Then .AddItem rg.Value
　　　　Next
　　　　.ListIndex = 0
　　End With
　　Application.ScreenUpdating = True
End Sub

Private Sub Combo1_Click()
　　Application.ScreenUpdating = False
　　'コンボボックスのリストを抽出(担当者)
　　ws2.UsedRange.Columns(2).AdvancedFilter xlFilterInPlace, , , True
　　With Combo2
　　　　.Clear
　　　　For Each rg In ws2.UsedRange.Columns(2).SpecialCells(xlCellTypeVisible)
　　　　　　If rg.Row <> 1 Then
　　　　　　　　If rg.Offset(0, -1) = Combo1.Text Then
　　　　　　　　　　.AddItem rg.Value
　　　　　　　　End If
　　　　　　End If
　　　　Next
　　　　.ListIndex = 0
　　End With
　　Application.ScreenUpdating = True
End Sub

お礼

回答ありがとうございます。
ちょっと難しそうですが、この方法ならできそうな気がします。

AdvancedFilterというのも初めて知りましたし、AddItemでリストに追加するというのは思いつきませんでした。まだまだ修行が足りません。色々勉強しながら取り組みたいと思います。
本当にありがとうございました。

回答No.1

tamagawa49

仮にSheet1（別シートらしいですが）に以下のようなデータを入力します。

　　　　Ａ　　　Ｂ　　　Ｃ

１　　Ａ社　　Ａ社　　佐藤
２　　Ｂ社　　Ａ社　　田中
３　　Ｃ社　　Ｂ社　　渡辺
　　　　　　　Ｂ社　　後藤
　　　　　　　Ｂ社　　鈴木
　　　　　　　Ｃ社　　中村

Comboboxに表示されるリストを指定するにはRowSourceを使います。

例えば、
Private Sub ComboBox1_Change()
If ComboBox1 = "Ａ社" Then
ComboBox2.RowSource = "Sheet1!C1: C2"
ElseIf ComboBox1 = "Ｂ社" Then
ComboBox2.RowSource = "Sheet1!C3: C5"
ElseIf ComboBox1 = "Ｃ社" Then
ComboBox2.RowSource = "Sheet1!C6"
Else
End If
End Sub

のように使います。もちろんComboBox1も"Sheet1!A1: A3"で指定します。
後の処理（結果がどこに書き込まれるか）は書いていませんが質問の部分にはお答えしたつもりです。
ではがんばって下さいね。

補足

素早い回答ありがとうございます。
RowSourceプロパティで指定するのは判っているのですが、発注先はとてもたくさん登録されている上に、新規の発注先や担当者が登録される可能性があるので、直接
If ComboBox1 = "Ａ社" Then
ComboBox2.RowSource = "Sheet1!C1: C2"
のようには指定できないのです。
まず、リストの中からＡ社ならＡ社に属する担当者リストを抽出した上で、Combo2のRowSourceに設定しなければならないと思うのです。
う～ん・・・無理かな？(^^;