| |
▼ぴ〜ちゃん さん：
こんばんは。
>ユーザーフォームを作り、そこにコンボボックス１、
>コンボボックス２を作ります。
>シート１にコンボボックス１で都道府県名を選択し、
>コンボボックス２で、１で選択した都道府県の「区市郡」
>を選択できるようにします。
> A B C D
>1 東京都 渋谷区 10000人 14000人
>2 東京都 新宿区 20000人 25000人
>3 東京都 港区 50000人 55000人
>4 茨城県 水戸市 20000人 20000人
>5 茨城県 つくば市 25000人 25000人
>6 茨城県 ひたちなか市 20000人 15000人
>. . .
>. . .
>. . .
>
>シート２の任意のセルを選択するとフォームが表示されて
>シート１で選択したコンボボックス１、コンボボックス２で
>１で選択した都道府県の「区市郡」を
>記入しコンボボックス２で選択した区市郡の人口 C、Dを
>合わせて貼り付けたいのです。
>
>シート２のA６を選択し、コンボボックス１−東京、
>コンボボックス２−港区を選択した場合はこのようにしたいです。
> A B C D
>1
>2
>3
>4
>5
>6 東京都 港区 50000人 55000人
>
>宜しくお願いします。
せっかく、このツリーに投稿していただいたので
このツリーで記述したコードを少し変更したコードにしました。
では、ユーザーフォーム（Userform1）には、
Combobox1（都道府県選択用)とCombobox2（区市郡選択用）と
CommandButton1（シートに貼付実行ボタン）を配置してください。
シート名は、都道府県、区市郡及び、人数ﾃﾞｰﾀの入っているマスターシートを
Sheet1（ぴ〜ちゃん さんがいあシート1)、
選択して貼り付けるシートのシート名は、任意でよいです（私は、Sheet2で確認しましたが・・・)
又、Sheet1のF列を作業列として使用した例です。作業列は、どこでもいいです。
尚、Sheet1にﾃﾞｰﾀがない場合のエラー処理はしていませんので、ご了承ください。
当該フォームモジュールに
'=========================================================
Private Sub UserForm_Initialize()
Dim func_str As String
func_str = "=if(countif(sheet1!$a$1:a1,a1)>1,"""",a1)"
Call set_combo_item(ComboBox1, func_str)
func_str = "=if(sheet1!a1=""" & ComboBox1.Text & """,sheet1!b1,"""")"
Call set_combo_item(ComboBox2, func_str)
End Sub
'=========================================================
Private Sub ComboBox1_Change()
Dim func_str As String
func_str = "=if(sheet1!a1=""" & ComboBox1.Text & """,sheet1!b1,"""")"
Call set_combo_item(ComboBox2, func_str)
End Sub
'=========================================================
Private Sub CommandButton1_Click()
Dim func_str As String
Dim rng As Range
func_str = "=if(and(sheet1!a1=""" & ComboBox1.Text & """,sheet1!b1=""" & ComboBox2.Text & """),row(),"""")"
Set rng = get_func_rng(func_str)
With ActiveCell
Cells(.Row, 1).Value = ComboBox1.Text
Cells(.Row, 2).Value = ComboBox2.Text
For idx = 3 To 4
Cells(.Row, idx).Value = Worksheets("sheet1").Cells(rng.Value, idx).Value
Next
End With
rng.Value = ""
End Sub
'=========================================================
Function get_func_rng(func_str As String) As Range
'input: func_str ﾃﾞｰﾀ抽出のための関数式
'out : get_func_rng 条件に合ったセル範囲
Dim rng As Range
With ThisWorkbook.Worksheets("sheet1")
Set rng = .Range("a1", .Range("a65536").End(xlUp))
End With
rng.Offset(0, 5).Formula = func_str
rng.Offset(0, 5) = rng.Offset(0, 5).Value
Set get_func_rng = rng.Offset(0, 5).SpecialCells(xlCellTypeConstants)
' ↑ここでＦ列を使っています、変更するなら5を別の数字に
End Function
'=========================================================
Sub set_combo_item(cmb As MSForms.ComboBox, func_str As String)
'input: cmb ﾃﾞｰﾀをセットするコンボボックス
'input: func_str ﾃﾞｰﾀ抽出のための関数式
Dim rng As Range
Dim rng2 As Range
Set rng2 = get_func_rng(func_str)
cmb.Clear
For Each rng In rng2
cmb.AddItem rng.Value
Next
cmb.ListIndex = 0
rng2.Value = ""
Set rng = Nothing
Set rng2 = Nothing
End Sub
次にシート2のシートモジュールに
'===========================================================
Private Sub Worksheet_Activate()
UserForm1.Show vbModeless
End Sub
'===========================================================
Private Sub Worksheet_Deactivate()
Unload UserForm1
End Sub
'===========================================================
Private Sub Worksheet_SelectionChange(ByVal Target As Range)
With UserForm1
If .Visible = False Then .Show vbModeless
End With
End Sub
尚、シート2では、コマンドボタンクリック時にどこのセルを選択しても
選択されたセルと同じ行のＡ列からﾃﾞｰﾀが貼り付けられる仕様になっています。
|
|
ichinose
- 03/12/13(土) 2:48 -
