Loop for checkbox's that are true and return the caption of each true checkbox in a seperate row of the same column

[sthyne]

I have a formula that loops through the checkboxes and places the captions as consecutive strings separated by a comma in the next column. I need to modify it so that each checkbox that is true is input on a separate row

Private Sub CommandButton1_Click()

Dim ans As String

Dim emptyrow As Long

For Each xcontrol In Me.Controls

If TypeName(xcontrol) = "CheckBox" Then

If xcontrol.Value = True Then ans = ans & xcontrol.Caption & "," & " "

End If

Next xcontrol

If ans = "" Then

MsgBox "You selected no CheckBoxes"

Else

ActiveCell.Offset(0, 1).Value = Left(ans, Len(ans) - 1)



End If

Unload Me

End Sub

 

[JEC]

Two methods below

Private Sub CommandButton1_Click()
 Dim ct, sq
 For Each ct In Me.Controls
   If TypeName(ct) = "CheckBox" Then
      If ct Then sq = sq & IIf(sq = "", "", ",") & ct.Caption
   End If
 Next
 With Sheets(1).Cells(1, 1)
   .Resize(30).ClearContents
   .Resize(UBound(Split(sq, ",")) + 1) = Application.Transpose(Split(sq, ","))
 End With
End Sub

Private Sub CommandButton1_Click()
 Dim sq(), ct, x
 For Each ct In Me.Controls
   If TypeName(ct) = "CheckBox" Then
      If ct Then
        ReDim Preserve sq(x)
        sq(x) = ct.Caption: x = x + 1
      End If
   End If
 Next
 With Sheets(1).Cells(1, 1)
    .Resize(30).ClearContents
    .Resize(x) = Application.Transpose(sq)
 End With
End Sub

 

[sthyne]

Two methods below

Private Sub CommandButton1_Click()
 Dim ct, sq
 For Each ct In Me.Controls
   If TypeName(ct) = "CheckBox" Then
      If ct Then sq = sq & IIf(sq = "", "", ",") & ct.Caption
   End If
 Next
 With Sheets(1).Cells(1, 1)
   .Resize(30).ClearContents
   .Resize(UBound(Split(sq, ",")) + 1) = Application.Transpose(Split(sq, ","))
 End With
End Sub

Private Sub CommandButton1_Click()
 Dim sq(), ct, x
 For Each ct In Me.Controls
   If TypeName(ct) = "CheckBox" Then
      If ct Then
        ReDim Preserve sq(x)
        sq(x) = ct.Caption: x = x + 1
      End If
   End If
 Next
 With Sheets(1).Cells(1, 1)
    .Resize(30).ClearContents
    .Resize(x) = Application.Transpose(sq)
 End With
End Sub

Thank you, that worked perfectly.

If I wanted them to always appear in the same column (for example column B) on the next empty row, how would I change the code for that?

 

[JEC]

For example

Private Sub CommandButton1_Click()
 Dim sq(), ct, x
 For Each ct In Me.Controls
   If TypeName(ct) = "CheckBox" Then
      If ct Then
        ReDim Preserve sq(x)
        sq(x) = ct.Caption: x = x + 1
      End If
   End If
 Next
 Sheets(1).Range("B" & Rows.Count).End(xlUp).Offset(1).Resize(x) = Application.Transpose(sq)
End Sub

 

[sthyne]

Perfect, thank you!

 

[JEC]

You're welcome!