在Excel VBA中将单选button的位置从垂直更改为水平
此代码从一组问题中生成问卷。 代码以单选button的forms生成一个新的表单，其中包含所有问题和选项。 代码现在显示所有的选项。 我们如何改变单选button的布局，并将所有选项显示在一行而不是一行之下。
代码如下：
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 这段代码没有经过testing，但是它可以做你想做的事情：
将下面的Dim与其余的variables尺寸相加：
Dim numOptions As Integer
添加这一段代码来replace你当前使用的位来设置每个控件的顶部和左侧位置：
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
该代码假定每个问题的单选button（列A中的“无线电”）立即出现问题（列A中的“问题”）。
（如果代码不起作用，请告诉我，我将删除答案。）