| |
▼mohimohi さん：
アップしたコードでは、項目名をコンスタントでチェック（祖父とか父とか）し
かつ、祖父なら CheckBox● と決めつけしています。
実際にはこれでいいのかもしれませんが、Ｅ列からＩ列に記入する項目名がかわれば
コードも変える必要がでてきます。
また、チェックボックスの数に増減があれば、コードを変更する必要がでてきます。
以下は、そのような時、コードを変えず、Ｅ列からＩ列に記入する項目名と
チェックボックスのキャプションを同じにしておけば、自動判定しますし、
チェックボックスの増減も任意です。
アップ済みコードと全く同じプロシジャもありますが、フルセット掲載します。
Option Explicit
Dim rfA As Range
Dim rfX As Range
Dim dic As Object
Private Sub CommandButton1_Click()
Dim WS As Worksheet
Dim x As Long
Dim ckb As OLEObject
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
If dic Is Nothing Then
Set dic = CreateObject("Scripting.Dictionary")
For Each ckb In OLEObjects
If TypeName(ckb.Object) = "CheckBox" Then dic(ckb.Object.Caption) = ckb.Name
Next
End If
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 ckName As String
Dim k As Variant
If ComboBox4.ListIndex < 0 Then Exit Sub
For Each k In dic
With OLEObjects(dic(k)).Object
.Value = False
.Enabled = False
End With
Next
i = ComboBox4.List(ComboBox4.ListIndex, 1)
z = Cells(i, Columns.Count).End(xlToLeft).Column
For j = 5 To z
If dic.exists(Cells(i, j).Value) Then
With OLEObjects(dic(Cells(i, j).Value)).Object
.Value = True
.Enabled = True
End With
End If
Next
End Sub
|
|
![[未読]](./data/excel/image/read_icon.gif){kind=icon}
