『VBAのユーザーフォームについて質問です。』（まき）
チェックボックスが複数あり、該当のチェックボックスをチェックすると
リストボックス1にチェックボックスと同じ値が表示され、
リストボックス2はそれに連動した値が選択できるようになっています。
複数のチェックボックスにチェックした状態で、
リストボックス2で複数選択の値の保持して、シート1のE列に転記したいです。
例）
■ユーザーフォーム
【リストボックス1】 【リストボックス2】
標準工事 標準4.9以下
標準7.1以下 ←これを選択
標準7.2以上
リストボックス1を跨ぐリストボックス2の複数の値選択は可能なのでしょうか。
また、自分で書いた下記のコードですと、リストボックス2の値が上書きされてしまいます。
どのように修正したらよいか教えてください。
Private Sub CommandButton1_Click()
Dim ctrl As Control
'ユーザーフォームのコントロールをループ
For Each ctrl In Controls
If InStr(ctrl.Name, "CheckBox") <> 0 Then 'チェックボックスがオンだったら
If ctrl.Value = True Then
'D列の最終行にチェックボックスのCaptionを転記
Cells(Cells(Rows.Count, 4).End(xlUp).Row + 1, 4) = ctrl.Caption
'E列の最終行に選択したリストボックスの値を転記
For i = 0 To ListBox2.ListCount - 1
If ListBox2.Selected(i) Then
With Worksheets("Sheet1")
'C列最終行を取得
LastRow = .Cells(Rows.Count, 4).End(xlUp).Row
'セルへ転記
.Cells(LastRow, 5) = ListBox2.List(i)
LastRow = LastRow + 1
End With
End If
Next
End If
End If
Next ctrl
End Sub
'--------------チェックボックスとリスト連動----------
'**【1】
'Private Sub CheckBox1_Change()
'
' With ListBox1
' If CheckBox1.Value Then
' .AddItem Worksheets("Sheet2").Range("A2").Value 'チェックボックス【1】が"標準工事"だったら
' Else
' .RemoveItem 0
' End If
' End With
'
'End Sub
'------リストから複数選択---------
Private Sub UserForm_Initialize()
With ListBox1
With ListBox2
.MultiSelect = fmMultiSelectMulti
' 'チェックボックス表示
' .ListStyle = fmListStyleOption
End With
End With
End Sub
'--------------リストボックス1とリストボックス2連動----------
Private Sub ListBox1_Change()
ListBox2.Clear
Select Case ListBox1.Text
Case "標準工事"
ListBox2.List = Worksheets("Sheet2").Range("B2:B6").Value
Case "付帯工事"
ListBox2.List = Worksheets("Sheet2").Range("B7:B20").Value
Case "特殊工事"
ListBox2.List = Worksheets("Sheet2").Range("B21:B44").Value
End Select
End Sub
'-------【標準工事】-------
Private Sub CheckBox2_Change()
If CheckBox2.Value = True Then
AAA = UserForm1.CheckBox2.Caption
ElseIf CheckBox2.Value = False Then
End If
With ListBox1
Select Case AAA
Case "標準工事"
End Select
If CheckBox2.Value = True Then
.AddItem Worksheets("Sheet2").Range("A2").Value
Else
.RemoveItem 0
ListBox2.Clear
End If
End With
End Sub
'-------【付帯工事】-------
Private Sub CheckBox5_Change()
If CheckBox5.Value = True Then
AAA = UserForm1.CheckBox5.Caption
ElseIf CheckBox2.Value = False Then
End If
With ListBox1
Select Case AAA
Case "付帯工事"
End Select
If CheckBox5.Value = True Then
.AddItem Worksheets("Sheet2").Range("A7").Value
Else
.RemoveItem 0
ListBox2.Clear
End If
End With
End Sub
'-------【特殊工事】-------
Private Sub CheckBox6_Change()
If CheckBox6.Value = True Then
AAA = UserForm1.CheckBox5.Caption
ElseIf CheckBox6.Value = False Then
End If
With ListBox1
Select Case AAA
Case "特殊工事"
End Select
If CheckBox6.Value = True Then
.AddItem Worksheets("Sheet2").Range("A21").Value
Else
.RemoveItem 0
ListBox2.Clear
End If
End With
End Sub
＜ 使用 Excel：Excel2016、使用 OS：Windows10 ＞
該当部のみ修正してみました。 ListBox2にも工事の種類を表示した方がよければ、 UserForm_Initializeの.ColumnWidths = "0;" を50とかに変更。 それでOKならListBox1は要らないと思いますけど・・・
'------リストから複数選択---------
Private Sub UserForm_Initialize()
ListBox1.MultiSelect = fmMultiSelectMulti
With ListBox2
.MultiSelect = fmMultiSelectMulti
.ColumnCount = 2
.ColumnWidths = "0;"
End With
End Sub
'--------------リストボックス1とリストボックス2連動----------
Private Sub ListBox1_Change()
Dim i As Long, n As Long, v(), arr()
Dim r As Range, rng As Range, tmp As Range
Dim str As String
ListBox2.Clear
ReDim v(0)
With ListBox1
For i = 0 To .ListCount - 1
If .Selected(i) Then
ReDim Preserve v(n)
v(n) = .List(i)
n = n + 1
End If
Next
End With
For i = 0 To UBound(v)
Select Case v(i)
Case "標準工事"
Set tmp = Worksheets("Sheet2").Range("A2:B6")
Case "付帯工事"
Set tmp = Worksheets("Sheet2").Range("A7:B20")
Case "特殊工事"
Set tmp = Worksheets("Sheet2").Range("A21:B44")
End Select
If rng Is Nothing Then
Set rng = tmp
Else
Set rng = Union(rng, tmp)
End If
Next
n = 0
If Not rng Is Nothing Then
For Each r In rng.Rows
If r.Cells(1).Value <> "" Then str = r.Cells(1)
If Not r.Cells(2) = "" Then
n = n + 1
ReDim Preserve arr(1 To 2, 1 To n)
arr(1, n) = str
arr(2, n) = r.Cells(2)
End If
Next
ListBox2.List = Application.Transpose(arr)
End If
End Sub
'--------------コマンドボタン２を設置して実行----------
Private Sub CommandButton2_Click()
Dim i As Long, n As Long, v()
With ListBox2
For i = 0 To .ListCount - 1
If .Selected(i) Then
n = n + 1
ReDim Preserve v(1 To 2, 1 To n)
v(1, n) = .List(i, 0)
v(2, n) = .List(i, 1)
End If
Next
End With
On Error Resume Next
Worksheets("Sheet1").Cells(Rows.Count, "D").End(xlUp) _
.Offset(1).Resize(UBound(v, 2), 2) = Application.Transpose(v)
On Error GoTo 0
End Sub
（サラスパ） 2023/09/30(土) 16:19:19
[ 一覧(最新更新順) ]
YukiWiki 1.6.7 Copyright (C) 2000,2001 by Hiroshi Yuki.
Modified by kazu.