『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 '--------------コマンドボタン2を設置して実行---------- 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.