此代码根据一组问题生成问卷。该代码生成一个新工作表，其中包含单选按钮形式的所有问题和选项。现在，代码会一个接一个地显示所有选项。我们如何更改单选按钮的布局并在一行中显示所有选项而不是另一行中的一个？
以下是代码：
Private Sub CommandButton1_Click()
Worksheets("Raw Data").Visible = xlSheetVeryHidden
Worksheets("Questions").Visible = xlSheetVeryHidden
Worksheets("Survey Results").Visible = xlSheetVeryHidden
If TextBox1.Value = "" And TextBox2.Value = "" Then
MsgBox " Please provide ID and Name"
Exit Sub
ElseIf TextBox1.Value = "" Then
MsgBox " Please provide ID"
Exit Sub
ElseIf TextBox2.Value = "" Then
MsgBox " Please provide Name"
Exit Sub
End If
Worksheets("Questions").Unprotect
Worksheets("Questions").Range("SV3") = TextBox1.Value
Z = Worksheets("Questions").Range("SV6").Value
If Z = "" Then
b = 0
ElseIf (Worksheets("Raw Data").Range("A" & Z).Value) = 1 Then
b = Worksheets("Raw Data").Range("A" & Z).Value
End If
If (Worksheets("Questions").Range("SV4").Value = Trim(TextBox1.Value)) And (b = 1) Then
MsgBox " You have already completed the survey !!!"
Unload UserForm1
Exit Sub
ElseIf Worksheets("Questions").Range("SV4").Value <> Trim(TextBox1.Value) Or b = "" Then
Unload UserForm1
NextRow = Worksheets("Raw Data").Range("B" & Rows.Count).End(xlUp).Row + 1
Worksheets("Raw Data").Range("B" & NextRow) = TextBox1.Value
Worksheets("Raw Data").Range("B" & NextRow).HorizontalAlignment = xlCenter
Worksheets("Raw Data").Range("B" & NextRow).Borders.LineStyle = xlContinuous
Worksheets("Raw Data").Range("C" & NextRow) = TextBox2.Value
Worksheets("Raw Data").Range("C" & NextRow).HorizontalAlignment = xlCenter
Worksheets("Raw Data").Range("C" & NextRow).Borders.LineStyle = xlContinuous
End If
Worksheets("Questions").Unprotect
'Worksheets("Questions").Range("A:A").Select
'Selection.AutoFilter
Worksheets("Questions").Range("$A$1:$F$94").AutoFilter Field:=1, Criteria1:="Ques"
NextRow = Worksheets("Questions").Range("B" & Rows.Count).End(xlUp).Row
Worksheets("Questions").Range("B2:B" & NextRow).Copy
Sheets("Raw Data").Range("D1").PasteSpecial Transpose:=True
Worksheets("Questions").Range("A:A").AutoFilter
'****************************
Dim lngCtrlLeft As Long
Dim lngCtrlTop As Long
Dim intLoop As Integer
Dim intQues As Integer
Dim intColType As Integer
Dim intLbl As Integer
Dim intCtrlStartRow As Integer
Dim ole As Excel.OLEObject
Dim wksControl As Excel.Worksheet
Dim wksQuestionnaire As Excel.Worksheet
Dim wbkNew As Excel.Workbook
Application.ScreenUpdating = False
Application.StatusBar = "Creating Questionnaire..."
Set wksControl = shtControl
wksControl.Unprotect
Set wbkNew = Application.ActiveWorkbook
Set wksQuestionnaire = wbkNew.Worksheets.Add
'Set wksQuestionnaire = ActiveWorkbook.VBProject.VBComponents(N).Name = "NewForm"
wksQuestionnaire.Name = "Questionnaire"
wksQuestionnaire.DrawingObjects.Delete
lngCtrlLeft = 20
lngCtrlTop = 25
intColType = 1
intLbl = 2
intCtrlStartRow = 1
For intLoop = intCtrlStartRow To wksControl.Range("A1").CurrentRegion.Rows.Count
Select Case wksControl.Cells(intLoop, intColType).Value
Case "Heading"
Set ole = wksQuestionnaire.OLEObjects.Add("Forms.Label.1")
Case "Ques"
Set ole = wksQuestionnaire.OLEObjects.Add("Forms.Label.1")
intQues = intQues + 1
Application.StatusBar = "Ques " & intQues & "..."
Case "Radio"
Set ole = wksQuestionnaire.OLEObjects.Add("Forms.OptionButton.1")
ole.Object.GroupName = "QGrp" & CStr(intQues)
Case "Check"
Set ole = wksQuestionnaire.OLEObjects.Add("Forms.CheckBox.1")
ole.Object.GroupName = "QGrp" & CStr(intQues)
Case "Text"
Set ole = wksQuestionnaire.OLEObjects.Add("Forms.TextBox.1")
Case "Spin"
Set ole = wksQuestionnaire.OLEObjects.Add("Forms.SpinButton.1")
Case "Button"
Set ole = wksQuestionnaire.OLEObjects.Add("Forms.CommandButton.1")
End Select
If wksControl.Cells(intLoop, intColType).Value = "Heading" Then
ole.Left = lngCtrlLeft - 5
lngCtrlTop = lngCtrlTop + 15
ole.Top = lngCtrlTop
ole.Object.Font.Size = 15
ole.Object.Font.Bold = True
End If
If wksControl.Cells(intLoop, intColType).Value = "Button" Then
ole.Left = lngCtrlLeft - 5
lngCtrlTop = lngCtrlTop + 15
ole.Top = lngCtrlTop
End If
If wksControl.Cells(intLoop, intColType).Value = "Ques" Then
ole.Left = lngCtrlLeft - 5
lngCtrlTop = lngCtrlTop + 15
ole.Top = lngCtrlTop
Else
ole.Left = lngCtrlLeft
ole.Top = lngCtrlTop
End If
If wksControl.Cells(intLoop, intColType).Value <> "Text" And wksControl.Cells(intLoop, intColType).Value <> "Button" And wksControl.Cells(intLoop, intColType).Value <> "Spin" Then
If wksControl.Cells(intLoop, intColType).Value = "Ques" Then
ole.Object.Caption = CStr(intQues) & ". " & wksControl.Cells(intLoop, intLbl).Value
Else
ole.Object.Caption = wksControl.Cells(intLoop, intLbl).Value
End If
ole.Object.WordWrap = False
ole.Object.AutoSize = True
ElseIf wksControl.Cells(intLoop, intColType).Value = "Spin" Then
ole.Left = ole.Left + 35
ole.LinkedCell = ole.TopLeftCell.Offset(1, -1).Address
ole.Object.Max = 0
ole.Object.Max = 5
ElseIf wksControl.Cells(intLoop, intColType).Value = "Button" Then
ole.Object.AutoSize = True
ole.Object.WordWrap = True
'ole.Object.Height = True
ole.Object.Caption = wksControl.Cells(intLoop, intLbl).Value
ole.Height = 23.5
ole.Width = 93
ole.Name = "Submit"
Dim Code1 As String
Code1 = vbNullString
Code1 = Code1 & "Private Sub Submit_Click()" & vbCrLf
Code1 = Code1 & "Dim lngAnsRow As Long" & vbCrLf
Code1 = Code1 & "Dim wbkCollate As Excel.Worksheet" & vbCrLf
Code1 = Code1 & "Dim wbkResponse As Excel.Worksheet" & vbCrLf
Code1 = Code1 & "lngAnsRow = 1" & vbCrLf
Code1 = Code1 & "Worksheets(""Raw Data"").Visible = xlSheetVeryHidden" & vbCrLf
Code1 = Code1 & "Worksheets(""Questions"").Visible = xlSheetVeryHidden" & vbCrLf
Code1 = Code1 & "Worksheets(""Survey Results"").Visible = xlSheetVeryHidden" & vbCrLf
Code1 = Code1 & "Worksheets(""Questions"").Unprotect" & vbCrLf
Code1 = Code1 & "Set wbkCollate = Worksheets(""Raw Data"")" & vbCrLf
Code1 = Code1 & "lngAnsRow = lngAnsRow + 1" & vbCrLf
Code1 = Code1 & "Set wbkResponse = Worksheets(""Questionnaire"")" & vbCrLf
Code1 = Code1 & "Call GetAns(wbkResponse, wbkCollate, lngAnsRow)" & vbCrLf
Code1 = Code1 & "Set sht1 = ThisWorkbook.Worksheets(""Raw Data"")" & vbCrLf
Code1 = Code1 & "LastRow1 = sht1.Cells(sht1.Rows.Count, ""C"").End(xlUp).Row" & vbCrLf
Code1 = Code1 & "If Worksheets(""Raw Data"").Cells(LastRow1, 1).Value = 1 Then" & vbCrLf
Code1 = Code1 & " Load UserForm3" & vbCrLf
Code1 = Code1 & " UserForm3.Show" & vbCrLf
Code1 = Code1 & " Application.DisplayAlerts = False" & vbCrLf
Code1 = Code1 & " WorkSheets(""Questionnaire"").Delete" & vbCrLf
'Code1 = Code1 & " Application.DisplayAlerts = True" & vbCrLf
Code1 = Code1 & "End If" & vbCrLf
Code1 = Code1 & "If Worksheets(""Raw Data"").Cells(LastRow1, 1).Value <> 1 Then" & vbCrLf
Code1 = Code1 & " MsgBox ""Please answer the questions to proceed further""" & vbCrLf
Code1 = Code1 & " Sheets(""Questionnaire"").Activate" & vbCrLf
Code1 = Code1 & "End If" & vbCrLf
Code1 = Code1 & "GoTo ExitEarly" & vbCrLf
Code1 = Code1 & "ExitEarly:" & vbCrLf
Code1 = Code1 & " On Error Resume Next" & vbCrLf
Code1 = Code1 & " Set wbkCollate = Nothing" & vbCrLf
Code1 = Code1 & " Set wbkResponse = Nothing" & vbCrLf
Code1 = Code1 & " Erase varFiles" & vbCrLf
Code1 = Code1 & " Erase varFile" & vbCrLf
Code1 = Code1 & "End Sub" & vbCrLf
Code1 = Code1 & "Function GetAns(wksSrc As Worksheet, wksTgt As Worksheet, lngAnsRow As Long)" & vbCrLf
Code1 = Code1 & "Dim objControl As OLEObject" & vbCrLf
Code1 = Code1 & "Dim strQues As String" & vbCrLf
Code1 = Code1 & "Dim strAns As String" & vbCrLf
Code1 = Code1 & "Dim lngCol As Long" & vbCrLf
Code1 = Code1 & "lngcCol = 3" & vbCrLf
Code1 = Code1 & "Set sht1 = ThisWorkbook.Worksheets(""Raw Data"")" & vbCrLf
Code1 = Code1 & "k = sht1.Cells(sht1.Rows.Count, ""D"").End(xlUp).Column" & vbCrLf
Code1 = Code1 & "For Each objControl In wksSrc.OLEObjects" & vbCrLf
Code1 = Code1 & " If TypeName(objControl.Object) =""Label"" Then" & vbCrLf
Code1 = Code1 & " lngCol = lngCol + 1" & vbCrLf
Code1 = Code1 & " strQues = objControl.Object.Caption" & vbCrLf
Code1 = Code1 & " strAns = "" " & vbCrLf
Code1 = Code1 & " End If" & vbCrLf
Code1 = Code1 & " If TypeName(objControl.Object) =""OptionButton"" Then" & vbCrLf
Code1 = Code1 & " If objControl.Object.Value = True Then" & vbCrLf
Code1 = Code1 & " strAns = strAns & objControl.Object.Caption" & vbCrLf
Code1 = Code1 & " UinptUsgFrq = getRskWghtNum(strQues, strAns)" & vbCrLf
Code1 = Code1 & " LastRow1 = sht1.Cells(sht1.Rows.Count, ""C"").End(xlUp).Row" & vbCrLf
Code1 = Code1 & " wksTgt.Cells((LastRow1), (k)) = UinptUsgFrq" & vbCrLf
Code1 = Code1 & " k = k + 1" & vbCrLf
Code1 = Code1 & " End If" & vbCrLf
Code1 = Code1 & " End If" & vbCrLf
Code1 = Code1 & " If TypeName(objControl.Object) =""TextBox"" Then" & vbCrLf
Code1 = Code1 & " If Trim(objControl.Object.Text) <> """" Then" & vbCrLf
Code1 = Code1 & " strAns = strAns & objControl.Object.Text" & vbCrLf
Code1 = Code1 & " UinptUsgFrq = getRskWghtNum(strQues, strAns)" & vbCrLf
Code1 = Code1 & " LastRow1 = sht1.Cells(sht1.Rows.Count, ""C"").End(xlUp).Row" & vbCrLf
Code1 = Code1 & " wksTgt.Cells((LastRow1), (k)) = UinptUsgFrq" & vbCrLf
Code1 = Code1 & " k = k + 1" & vbCrLf
Code1 = Code1 & " End If" & vbCrLf
Code1 = Code1 & " End If" & vbCrLf
Code1 = Code1 & " If TypeName(objControl.Object) =""CheckBox"" Then" & vbCrLf
Code1 = Code1 & " If objControl.Object.Value = True Then" & vbCrLf
Code1 = Code1 & " strAns = strAns & objControl.Object.Caption" & vbCrLf
Code1 = Code1 & " UinptUsgFrq = getRskWghtNum(strQues, strAns)" & vbCrLf
Code1 = Code1 & " LastRow1 = sht1.Cells(sht1.Rows.Count, ""C"").End(xlUp).Row" & vbCrLf
Code1 = Code1 & " wksTgt.Cells((LastRow1), (k)) = UinptUsgFrq" & vbCrLf
Code1 = Code1 & " k = k + 1" & vbCrLf
Code1 = Code1 & " End If" & vbCrLf
Code1 = Code1 & " End If" & vbCrLf
Code1 = Code1 & "Next objControl" & vbCrLf
Code1 = Code1 & "Set objControl = Nothing" & vbCrLf
Code1 = Code1 & "End Function" & vbCrLf
Code1 = Code1 & "Function getRskWghtNum(strQues, strAns)" & vbCrLf
Code1 = Code1 & "intStartRow = 2" & vbCrLf
Code1 = Code1 & "intStartRow1 = 2" & vbCrLf
Code1 = Code1 & "strquest = Split(strQues,"". "")" & vbCrLf
Code1 = Code1 & "strQues1 = strquest(1)" & vbCrLf
Code1 = Code1 & "strAns1 = Trim(strAns)" & vbCrLf
Code1 = Code1 & "Do While Trim(Sheets(""Questions"").Cells(intStartRow1, 2)) <> """ & vbCrLf
Code1 = Code1 & " If Trim((Sheets(""Questions"").Cells(intStartRow1, 2).Value) = strQues1) Then" & vbCrLf
Code1 = Code1 & " If Trim((Sheets(""Questions"").Cells(intStartRow, 2).Value)) = strAns1 Then" & vbCrLf
Code1 = Code1 & " getRskWghtNum = Trim(Sheets(""Questions"").Cells(intStartRow, 3).Value)" & vbCrLf
Code1 = Code1 & " Exit Do" & vbCrLf
Code1 = Code1 & " End If" & vbCrLf
Code1 = Code1 & " intStartRow = intStartRow + 1" & vbCrLf
Code1 = Code1 & " Else" & vbCrLf
Code1 = Code1 & " intStartRow1 = intStartRow1 + 1" & vbCrLf
Code1 = Code1 & " intStartRow = intStartRow1" & vbCrLf
Code1 = Code1 & " End If" & vbCrLf
Code1 = Code1 & "Loop" & vbCrLf
Code1 = Code1 & "End Function" & vbCrLf
With ThisWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
'With Worksheets(wksControl.Cells(intLoop, intLbl).Value)
'With ActiveWorkbook.ole.Object.CodeModule
Nextline = CountOfLines + 1
.insertlines Nextline, Code1
End With
ElseIf wksControl.Cells(intLoop, intColType).Value = "Text" Then
ole.Object.AutoSize = False
ole.Object.WordWrap = True
ole.Object.IntegralHeight = False
ole.Width = 175
ole.Height = 17
End If
lngCtrlTop = lngCtrlTop + 16
Next intLoop
wksControl.Protect
DoEvents
wbkNew.Activate
With ActiveWindow
.DisplayGridlines = False
.DisplayHeadings = False
End With
Worksheets("Questionnaire").Range("D1:D5").EntireRow.Insert
Worksheets("Questionnaire").Range("A1:A3").EntireColumn.Insert
wksQuestionnaire.Rows(CStr(ole.TopLeftCell.Offset(3).Row) & ":" & CStr(wksQuestionnaire.Rows.Count)).Hidden = True
Application.StatusBar = "Saving Questionnaire to Desktop..."
Worksheets("Questionnaire").Range("B3:K5").Merge
Worksheets("Questionnaire").Range("B3").Interior.ColorIndex = 37
Worksheets("Questionnaire").Range("B3").Value = "Customer Satisfaction Survey - Questionarie"
Worksheets("Questionnaire").Range("B3").Font.ColorIndex = 1
Worksheets("Questionnaire").Range("B3").Font.Size = 20
Worksheets("Questionnaire").Range("B3").Font.Bold = True
Worksheets("Questionnaire").Range("B3:K5").HorizontalAlignment = xlCenter
Worksheets("Questionnaire").Range("B3:K5").VerticalAlignment = xlCenter
Worksheets("Questionnaire").Range("B3:K5").Borders.LineStyle = xlContinuous
Worksheets("Questionnaire").Range("A:A").ColumnWidth = 21.57
Set ole = Nothing
Set wksControl = Nothing
Set wksQuestionnaire = Nothing
Set wbkNew = Nothing
End Sub
答案 0 :(得分：3)
此代码未经过测试，但可能会执行您想要的操作：
将以下Dim添加到变量尺寸标注的其余部分：
Dim numOptions As Integer
添加以下代码来替换当前用于设置每个控件的顶部和左侧位置的位：
If wksControl.Cells(intLoop, intColType).Value = "Heading" Then
ole.Left = lngCtrlLeft - 5
lngCtrlTop = lngCtrlTop + 15
ole.Top = lngCtrlTop
ole.Object.Font.Size = 15
ole.Object.Font.Bold = True
ElseIf wksControl.Cells(intLoop, intColType).Value = "Button" Then
ole.Left = lngCtrlLeft - 5
lngCtrlTop = lngCtrlTop + 15
ole.Top = lngCtrlTop
ElseIf wksControl.Cells(intLoop, intColType).Value = "Ques" Then
ole.Left = lngCtrlLeft - 5
lngCtrlTop = lngCtrlTop + 15
ole.Top = lngCtrlTop
numOptions = 0
ElseIf wksControl.Cells(intLoop, intColType).Value = "Radio" Then
ole.Left = lngCtrlLeft + numOptions * 30 ' the "30" might need to be changed to provide appropriate spacing
lngCtrlTop = lngCtrlTop - 16 ' to get rid of the effect of adding 16 at the end of the loop
ole.Top = lngCtrlTop
numOptions = numOptions + 1
Else
ole.Left = lngCtrlLeft
ole.Top = lngCtrlTop
End If
代码假定每个问题的单选按钮（＆＃34; Radio＆＃34; A列中）立即提出问题（＆＃34; Ques＆＃34;在A栏中）。
（如果代码不起作用，请告诉我，我会删除答案。）