Excel中的VBA UserForm – 电子表格数据条目中的行不匹配

我有一个通过VBA创build的应用程序表单应该填充Excel工作表上的行。 它确实，但他们是一个：

Name | Race | Agency Black Joe Asian B White Joanne C 

乔的比赛是黑人和亚洲人，在B组; 乔安妮是白色的，而她在C级。不知何故，参赛作品是错开的。

名称是一个文本框，种族和机构是列表框，作为一个多选和机构作为一个单一的select比赛。

这是我的代码：

 Private Sub CommandButton1_Click() Dim j As Long Dim i As Integer With ListBox2 ReDim arr(.ListCount - 1) For i = 0 To .ListCount - 1 If .Selected(i) = True Then .Selected(i) = False arr(j) = .List(i) j = j + i End If Next i End With ReDim Preserve arr(j) With ActiveSheet .Range("B" & .Rows.Count).End(xlUp). _ Offset(1, 0).Resize(j + 1, 1).Value = Application.Transpose(arr) End With i = 1 While ThisWorkbook.Worksheets("Sheet1").Range("B" & i).Value <> "" i = i + 1 Wend ThisWorkbook.Worksheets("Sheet1").Range("A" & i).Value = TextBox1.Value ThisWorkbook.Worksheets("Sheet1").Range("C" & i).Value = ListBox1.Value End Sub Private Sub CommandButton2_Click() Dim ctl As MSForms.Control For Each ctl In Me.Controls Select Case TypeName(ctl) Case "TextBox" ctl.Text = "" Case "CheckBox", "OptionButton", "ToggleButton" ctl.Value = False Case "ComboBox", "ListBox" ctl.ListIndex = -1 End Select Next ctl End Sub Sub UserForm_Initialize() ListBox1.List = Array("A", "B", "C") With ListBox2 .Clear .AddItem "White" .AddItem "Black" .AddItem "Asian" .AddItem "Am Indian/Al Native" .AddItem "Native Hawaiian/Pac Islander" .AddItem "Other" End With End Sub 

我会喜欢任何想法你会有如何解决这个问题！ 理想情况下，它会以下列方式之一出现：

 Name | Race | Agency Joe Black B Asian B Joanne White C 

要么

 Name | Race | Agency Joe Black, Asian B Joanne White C 

要么

 Name | Race | Agency Joe Black B Joe Asian B Joanne White C 

（我更喜欢第二，但任何工作。）

Answer 1

如果我正确理解代码，下面重构的CommandButton1_Click过程应该为您生成首选结果。

 Private Sub CommandButton1_Click() Dim j As Long Dim i As Integer 'load races into array With ListBox2 ReDim arr(.ListCount - 1) For i = 0 To .ListCount - 1 If .Selected(i) = True Then .Selected(i) = False arr(j) = .List(i) j = j + i End If Next i End With ReDim Preserve arr(j) 'build "," separated string of races For i = LBound(arr) To UBound(arr) Dim sRace As String sRace = sRace & "," & arr(i) Next sRace = Mid(sRace, 2) 'to remove first comma 'place info on next available line in sheet. With ThisWorkbook.Worksheets("Sheet1") Dim lRow As Long lRow = .Range("A" & .Rows.Count).End(xlUp).Offset(1).Row .Range("A" & lRow).Value = TextBox1.Value .Range("B" & lRow).Value = sRace .Range("C" & lRow).Value = ListBox1.Value End With End Sub