[[20230930112723]]　『VBAのユーザーフォームについて質問です。』（まき）　ページの最後に飛ぶ

『VBAのユーザーフォームについて質問です。』（まき）

チェックボックスが複数あり、該当のチェックボックスをチェックすると
リストボックス1にチェックボックスと同じ値が表示され、
リストボックス2はそれに連動した値が選択できるようになっています。

複数のチェックボックスにチェックした状態で、
リストボックス2で複数選択の値の保持して、シート1のE列に転記したいです。

例）
■ユーザーフォーム

【チェックボックス】
☑標準工事　　　☑特殊工事
□付帯工事　　　□部品交換　　　　←チェックすると下のリストボックスが1→2の順で
□電気工事　　　□キャンセル　　　　連動するようになっています。

【リストボックス1】　　　【リストボックス2】
標準工事　　　　　　　　　標準4.9以下
　　　　　　　　　　　　　標準7.1以下　←これを選択
　　　　　　　　　　　　　標準7.2以上

*********************************************************

特殊工事　　　　　　　　　屋上設置
　　　　　　　　　　　　　高所作業料
　　　　　　　　　　　　　スライダー安全対策←これを選択

シート1のD列最終行+1に"標準7.1以下"、その下の行に"スライダー安全対策"と続けて転記したい

リストボックス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

チェックボックスが全て☑されたらどうするの。
その対策は。
（?） 2023/09/30(土) 18:58:26

コメント返信：

[ 一覧(最新更新順) ]

[[20230930112723]] 『VBAのユーザーフォームについて質問です。』（まき） ページの最後に飛ぶ

*********************************************************

[[20230930112723]]　『VBAのユーザーフォームについて質問です。』（まき）　ページの最後に飛ぶ