Excel VBA質問箱 IV

当質問箱は、有志のボランティア精神のおかげで成り立っています。
問題が解決したら、必ずお礼をしましょうね。
本サイトの基本方針をまとめました。こちらをご一読ください。

投稿種別の選択が必要です。ご注意ください。
迷惑投稿防止のため、URLの入力を制限しています。ご了承ください。


	新規投稿 ┃ツリー表示 ┃一覧表示 ┃トピック表示 ┃検索 ┃設定 ┃過去ログ ┃ホーム

5324 / 76732

←次へ　｜　前へ→


	【77021】Re:コンボボックスとチェックボックスの連動に関する質問

β - 15/5/6(水) 7:46 -


	引用なし

	パスワード

▼mohimohi さん：

一例として。
作業シートとして "Sheet2" を使います。
抽出そのものは、あオートフィルターや重複の削除といったエクセル標準機能を使っています。

書きなぐったので、同じような処理コードが何回も出てきます。
このあたりは整理して共通サブルーティン化もできるところでしょう。

Option Explicit

Dim rfA As Range
Dim rfX As Range

Private Sub CommandButton1_Click()
　　Dim WS As Worksheet
　　Dim x As Long
　　
　　Set WS = Sheets("Sheet2")
　　ComboBox2.Clear
　　ComboBox3.Clear
　　ComboBox4.Clear
　　ComboBox1.Value = ""
　　ComboBox2.Value = ""
　　ComboBox3.Value = ""
　　ComboBox4.Value = ""
　　
　　WS.UsedRange.Clear
　　WS.AutoFilterMode = False
　　Range("A1").CurrentRegion.Columns("A:D").Copy WS.Range("A1")
　　WS.Range("E1").Value = 1
　　WS.Range("A1").CurrentRegion.Columns("E").DataSeries Rowcol:=xlColumns, Type:=xlLinear, Date:=xlDay, Step:=1, Trend:=False
　　WS.Range("A1").AutoFilter
　　Set rfA = WS.AutoFilter.Range
　　Set rfX = WS.Cells(rfA.Rows.Count + 2, "A")
　　WS.Range("A1").CurrentRegion.Columns("A").Copy WS.Range("G1")
　　WS.Range("G1").CurrentRegion.RemoveDuplicates Columns:=1, Header:=xlYes
　　With WS.Range("G1").CurrentRegion
　　　　ComboBox1.List = .Offset(1).Resize(.Count - 1).Value
　　End With
　　　　For x = 1 To 8
　　　　OLEObjects("CheckBox" & x).Object.Value = False
　　　　OLEObjects("CheckBox" & x).Object.Enabled = False
　　Next

End Sub

Private Sub ComboBox1_Change()

　　If ComboBox1.ListIndex < 0 Then Exit Sub
　　
　　ComboBox2.Clear
　　ComboBox3.Clear
　　ComboBox4.Clear
　　ComboBox2.Value = ""
　　ComboBox3.Value = ""
　　ComboBox4.Value = ""
　　
　　rfA.AutoFilter Field:=1, Criteria1:=ComboBox1.Value
　　If rfA.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count = 1 Then Exit Sub
　　rfX.CurrentRegion.Clear
　　Intersect(rfA, rfA.Offset(1)).Copy rfX
　　rfX.CurrentRegion.RemoveDuplicates Columns:=2, Header:=xlNo
　　With rfX.CurrentRegion.Columns("B")
　　　　ComboBox2.List = .Value
　　End With
　　
End Sub

Private Sub ComboBox2_Change()

　　If ComboBox2.ListIndex < 0 Then Exit Sub
　　
　　ComboBox3.Clear
　　ComboBox4.Clear
　　ComboBox3.Value = ""
　　ComboBox4.Value = ""
　　
　　rfA.AutoFilter Field:=1, Criteria1:=ComboBox1.Value
　　rfA.AutoFilter Field:=2, Criteria1:=ComboBox2.Value
　　If rfA.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count = 1 Then Exit Sub
　　rfX.CurrentRegion.Clear
　　Intersect(rfA, rfA.Offset(1)).Copy rfX
　　rfX.CurrentRegion.RemoveDuplicates Columns:=3, Header:=xlNo
　　With rfX.CurrentRegion.Columns("C")
　　　　ComboBox3.List = .Value
　　End With
　　
End Sub

Private Sub ComboBox3_Change()

　　If ComboBox3.ListIndex < 0 Then Exit Sub
　　
　　ComboBox4.Clear
　　ComboBox4.Value = ""
　　
　　rfA.AutoFilter Field:=1, Criteria1:=ComboBox1.Value
　　rfA.AutoFilter Field:=2, Criteria1:=ComboBox2.Value
　　rfA.AutoFilter Field:=3, Criteria1:=ComboBox3.Value
　　If rfA.Columns(1).SpecialCells(xlCellTypeVisible).Cells.Count = 1 Then Exit Sub
　　rfX.CurrentRegion.Clear
　　Intersect(rfA, rfA.Offset(1)).Copy rfX
　　With rfX.CurrentRegion.Columns("D:E")
　　　　ComboBox4.List = .Value
　　End With
　　
End Sub

Private Sub ComboBox4_Change()
　　Dim i As Long
　　Dim j As Long
　　Dim z As Long
　　Dim x As Long
　　
　　If ComboBox4.ListIndex < 0 Then Exit Sub
　　
　　For x = 1 To 8
　　　　OLEObjects("CheckBox" & x).Object.Value = False
　　　　OLEObjects("CheckBox" & x).Object.Enabled = False
　　Next
　　i = ComboBox4.List(ComboBox4.ListIndex, 1)
　　z = Cells(i, Columns.Count).End(xlToLeft).Column
　　For j = 5 To z
　　　　x = 0
　　　　Select Case Cells(i, j).Value
　　　　　　Case "祖父"
　　　　　　　　x = 3
　　　　　　Case "祖母"
　　　　　　　　x = 4
　　　　　　Case "父"
　　　　　　　　x = 1
　　　　　　Case "母"
　　　　　　　　x = 2
　　　　　　Case "兄"
　　　　　　　　x = 5
　　　　　　Case "姉"
　　　　　　　　x = 6
　　　　　　Case "弟"
　　　　　　　　x = 7
　　　　　　Case "妹"
　　　　　　　　x = 8
　　　　End Select
　　　　
　　　　If x > 0 Then
　　　　　　OLEObjects("CheckBox" & x).Object.Value = True
　　　　　　OLEObjects("CheckBox" & x).Object.Enabled = True
　　　　End If
　　Next
　　
End Sub

744 hits

▼

【77005】コンボボックスとチェックボックスの連動に関する質問 mohimohi 15/5/5(火) 0:04