Excel VBA从控制窗体框调用Sub时出错

Question

我正在VBA中构建一个非常匆忙的多层宏，它应该做以下事情：

1. 用户在起始页上选择数字1-4；将出现额外的工作表1-4，并调用第一个模块来格式化工作表（工作成功）
2. 用户导航到4个工作表中的第一个，回答问题1，然后2-4填充（成功工作）
3. 用户填写问题2-4（可能更多取决于标准），然后单击按钮（控制窗体，而不是活动-x）从另一个子系统运行宏（这是它失败的地方）

如果我从模块本身运行它，那么分配给按钮的代码就可以工作。如果我从按钮运行它，它不会执行辅助子调用（例如：它将"Hood 1"添加到一个范围值中，但它不会执行宏调用来格式化"Hood"下列出的列

添加runbox:

    'Removes the old run button
Wks.Shapes.Range(Array("RunBox")).Delete
Set RunBoxRng = Nothing
Set RunBoxRng = Ans1Rng.Offset(3, 3)
'Adds button to populate the rest of the questions
With RunBoxRng.Resize(3, 2)
    Set RunBox = Wks.Buttons.Add(.Left, .Top, .Width, .Height)
End With
With RunBox
    .Name = "RunBox"
    .Characters.Text = "Answer All Questions to the Left Then Click Here"
    With .Characters(Start:=1, Length:=48).Font
        .FontStyle = "Bold"
        .Size = 12
    End With
    .Display3DShading = True
    If Ans1Rng.Value > 1 Then
        .OnAction = Nothing
        .OnAction = "PopulateQuestions.PopulateQuestions"
    End If
    If Ans1Rng.Value = 1 Then
        .OnAction = Nothing
        .OnAction = "Populate1HoodQs.Populate1HoodQs"
    End If
    .Locked = False
End With

这将成功地从其他模块中提取，但不会让这些模块调用它们的辅助子系统。

二次调用示例：

If Not HoodRng1 Is Nothing Then
    HoodRng1.Value = "Hood 1"              'Works
    Call PopulateHood1Qs.PopulateHood1Qs   'Doesn't work
End If
If Not HoodRng2 Is Nothing Then
    HoodRng2.Value = "Hood 2"              'Works
    Call PopulateHood2Qs.PopulateHood2Qs   'Doesn't work
End If
If Not HoodRng3 Is Nothing Then
    HoodRng3.Value = "Hood 3"              'Works
    Call PopulateHood3Qs.PopulateHood3Qs   'Doesn't work
End If
If Not HoodRng4 Is Nothing Then
    HoodRng4.Value = "Hood 4"              'Works
    Call PopulateHood4Qs.PopulateHood4Qs  'Doesn't work
End If

因为这个原因，我已经36个小时没有睡觉了，如果不从模块手动运行它，我找不到让它工作的方法。这也使得我的FormatMerging子也不能被调用。请有人救我，我做错了什么？！

编辑：第二个PopulateHood1Qs1模块的第一部分：

       Set HoodRng1 = Nothing
Set Ans2Rng = Nothing
Set Ans3Rng = Nothing
Set Ans4Rng = Nothing
Set HoodRng1 = .UsedRange.Find(What:="Hood 1", LookAt:=xlWhole)
Set Ans2Rng = .UsedRange.Find(What:="General Questions").Offset(4, 4)
Set Ans3Rng = Ans2Rng.Offset(2)
Set Ans4Rng = Ans3Rng.Offset(2)
'Defines hood question strings
HoodQ = "What is the length of Hood 1?"
ASPQ = "How many appliance specific coverages are required?"
ZODQ = "Is the Hood protected by continuous Linear Heat Detection?"
ZOPQ = "How many Zones of Protection are there?"
DuctQ = "How many ducts are in Hood 1?"
'Defines question ranges
Set Q1Rng1 = Nothing
Set Q2Rng1 = Nothing
Set Q3Rng1 = Nothing
Set Q4Rng1 = Nothing
Set Q5Rng1 = Nothing
Set Ans1Rng1 = Nothing
Set Ans2Rng1 = Nothing
Set Ans3Rng1 = Nothing
Set Ans4Rng1 = Nothing
Set Ans5Rng1 = Nothing
Set Q1Rng1 = HoodRng1.Offset(2)
Set Q2Rng1 = Q1Rng1.Offset(2)
Set Q3Rng1 = Q2Rng1.Offset(2)
Set Q4Rng1 = Q3Rng1.Offset(2)
Set Q5Rng1 = Q4Rng1.Offset(2)
Set Ans1Rng1 = Q1Rng1.Offset(, LineSz)
Set Ans2Rng1 = Q2Rng1.Offset(, LineSz)
Set Ans3Rng1 = Q3Rng1.Offset(, LineSz)
Set Ans4Rng1 = Q4Rng1.Offset(, LineSz)
Set Ans5Rng1 = Q5Rng1.Offset(, LineSz)
'Adds questions 1 & 2
Q1Rng1.Value = "1. " & HoodQ
Q2Rng1.Value = "2. " & ASPQ
'Determines where to add the next question
Set NextQRng = Q3Rng1
'If adding linear heat
If Ans2Rng.Value = 2 Then
    NextQRng.Value = ZODQ
    Set NextQRng = NextQRng.Offset(2)
End If
'If adding ZOP
If Ans3Rng.Value = 2 Then
    NextQRng.Value = ZOPQ
    Set NextQRng = NextQRng.Offset(2)
End If
'If adding ducts
If Ans4Rng.Value = 2 Then
    If NextQRng.Offset(-2).Value <> DuctQ And NextQRng.Offset(-4).Value <> DuctQ And NextQRng.Offset(-6).Value <> DuctQ Then
        NextQRng.Value = DuctQ
    End If
End If
'Adds numbers
If Q3Rng1.Value <> "" Then Q3Rng1.Value = "3. " & Q3Rng1.Value
If Q4Rng1.Value <> "" Then Q4Rng1.Value = "4. " & Q4Rng1.Value
If Q5Rng1.Value <> "" Then Q5Rng1.Value = "5. " & Q5Rng1.Value
'Defines box ranges
Set ASPRng1 = Nothing
Set ZODRng1 = Nothing
Set ZOPRng1 = Nothing
Set DuctRng1 = Nothing
Set ASPRng1 = Ans2Rng1
Set ZODRng1 = HoodRng1.EntireColumn.Find(What:="Is the Hood protected by continuous Linear Heat Detection", LookAt:=xlPart).Offset(, LineSz)
Set ZOPRng1 = HoodRng1.EntireColumn.Find(What:="Zones of Protection", LookAt:=xlPart).Offset(, LineSz)
Set DuctRng1 = HoodRng1.EntireColumn.Find(What:="How many ducts", LookAt:=xlPart).Offset(, LineSz)
'Names Hazard 1
If InStr(1, Wks.Name, "1") > 0 Then
    If Not ASPRng1 Is Nothing Then ASPRng1.Name = "H1ASPRng1"
    If Not ZODRng1 Is Nothing Then ZODRng1.Name = "H1ZODRng1"
    If Not ZOPRng1 Is Nothing Then ZOPRng1.Name = "H1ZOPRng1"
    If Not DuctRng1 Is Nothing Then DuctRng1.Name = "H1DuctRng1"
End If
'Names Hazard 2
If InStr(1, Wks.Name, "2") > 0 Then
    If Not ASPRng1 Is Nothing Then ASPRng1.Name = "H2ASPRng1"
    If Not ZODRng1 Is Nothing Then ZODRng1.Name = "H2ZODRng1"
    If Not ZOPRng1 Is Nothing Then ZOPRng1.Name = "H2ZOPRng1"
    If Not DuctRng1 Is Nothing Then DuctRng1.Name = "H2DuctRng1"
End If
'Names Hazard 3
If InStr(1, Wks.Name, "3") > 0 Then
    If Not ASPRng1 Is Nothing Then ASPRng1.Name = "H3ASPRng1"
    If Not ZODRng1 Is Nothing Then ZODRng1.Name = "H3ZODRng1"
    If Not ZOPRng1 Is Nothing Then ZOPRng1.Name = "H3ZOPRng1"
    If Not DuctRng1 Is Nothing Then DuctRng1.Name = "H3DuctRng1"
End If
    'Names Hazard 1
If InStr(1, Wks.Name, "4") > 0 Then
    If Not ASPRng1 Is Nothing Then ASPRng1.Name = "H4ASPRng1"
    If Not ZODRng1 Is Nothing Then ZODRng1.Name = "H4ZODRng1"
    If Not ZOPRng1 Is Nothing Then ZOPRng1.Name = "H4ZOPRng1"
    If Not DuctRng1 Is Nothing Then DuctRng1.Name = "H4DuctRng1"
End If
'Adds ASP box
With ASPRng1
    If Wks.Shapes.Range(Array("ASPBox1")) Is Nothing Then Set ASPBox1 = Wks.DropDowns.Add(.Left, .Top + 0.75, .Width - 0.5, .Height - 1.6)
End With
With ASPBox1
    .Name = "ASPBox1"
    .ListFillRange = "ZeroToFour"
    If InStr(1, Wks.Name, "1") > 0 Then .LinkedCell = "H1ASPRng1"
    If InStr(1, Wks.Name, "2") > 0 Then .LinkedCell = "H2ASPRng1"
    If InStr(1, Wks.Name, "3") > 0 Then .LinkedCell = "H3ASPRng1"
    If InStr(1, Wks.Name, "4") > 0 Then .LinkedCell = "H4ASPRng1"
    .DropDownLines = 9
    .Display3DShading = True
    .Locked = False
    .Deselect
End With
'Adds ZOD box
With ZODRng1
    If Wks.Shapes.Range(Array("ZODBox1")) Is Nothing Then Set ZODBox1 = Wks.DropDowns.Add(.Left, .Top + 0.75, .Width - 0.5, .Height - 1.6)
End With
With ZODBox1
    .Name = "ZODBox1"
    .ListFillRange = "YesNo"
    If InStr(1, Wks.Name, "1") > 0 Then .LinkedCell = "H1ZODRng1"
    If InStr(1, Wks.Name, "2") > 0 Then .LinkedCell = "H2ZODRng1"
    If InStr(1, Wks.Name, "3") > 0 Then .LinkedCell = "H3ZODRng1"
    If InStr(1, Wks.Name, "4") > 0 Then .LinkedCell = "H4ZODRng1"
    .DropDownLines = 9
    .Display3DShading = True
    .Locked = False
    .Deselect
End With
'Adds ZOP box
With ZOPRng1
    If Wks.Shapes.Range(Array("ZOPBox1")) Is Nothing Then Set ZOPBox1 = Wks.DropDowns.Add(.Left, .Top + 0.75, .Width - 0.5, .Height - 1.6)
End With
With ZOPBox1
    .Name = "ZOPBox1"
    .ListFillRange = "ZeroToFour"
    If InStr(1, Wks.Name, "1") > 0 Then .LinkedCell = "H1ZOPRng1"
    If InStr(1, Wks.Name, "2") > 0 Then .LinkedCell = "H2ZOPRng1"
    If InStr(1, Wks.Name, "3") > 0 Then .LinkedCell = "H3ZOPRng1"
    If InStr(1, Wks.Name, "4") > 0 Then .LinkedCell = "H4ZOPRng1"
    .DropDownLines = 9
    .Display3DShading = True
    .Locked = False
    .Deselect
End With
'Adds Duct box
With DuctRng1
    Set DuctBox1 = Wks.DropDowns.Add(.Left, .Top + 0.75, .Width - 0.5, .Height - 1.6)
End With
With DuctBox1
    .Name = "DuctBox1"
    .ListFillRange = "DuctList"
    If InStr(1, Wks.Name, "1") > 0 Then .LinkedCell = "H1DuctRng1"
    If InStr(1, Wks.Name, "2") > 0 Then .LinkedCell = "H2DuctRng1"
    If InStr(1, Wks.Name, "3") > 0 Then .LinkedCell = "H3DuctRng1"
    If InStr(1, Wks.Name, "4") > 0 Then .LinkedCell = "H4DuctRng1"
    .DropDownLines = 9
    .Display3DShading = True
    .Locked = False
    .Deselect
End With
'Adds default values
If Not ASPRng1 Is Nothing Then ASPRng1.Value = 1
If Not ZOPRng1 Is Nothing Then ZOPRng1.Value = 2
If Not ZODRng1 Is Nothing Then ZODRng1.Value = 1
If Not DuctRng1 Is Nothing Then DuctRng1.Value = 1
'Defines range for new button
Set RunBoxRng1 = Nothing
Set RunBoxRng1 = Q5Rng1.Offset(2, 1)
'Adds button to populate the rest of the questions
With RunBoxRng1.Resize(2, 2)
    If Wks.Shapes.Range(Array("RunBox1")) Is Nothing Then Set RunBox1 = Wks.Buttons.Add(.Left, .Top, .Width, .Height)
End With
With RunBox1
    .Name = "RunBox1"
    .Characters.Text = "Answer All Fields and Click to Populate"
    .Display3DShading = True
    .OnAction = "PopulateHood1Qs.PopulateHood1Part2"
    .Locked = False
    .Deselect
End With
'Realigns
With RunBoxRng1.Resize(2, 2)
    RunBox1.Top = .Top
    RunBox1.Height = .Height
    RunBox1.Width = .Width
    RunBox1.Left = .Left
End With

我上传了一份失败的各种形式的副本。上传到此处

Answer 1

我同意Tim Williams的观点；问题可能与Populate1HoodQs和PopulateQuestions有关。我测试了代码，没有任何问题。您是否尝试在Populate1HoodQs和PopulateQuestions中设置断点，以查看它们是否真的被调用？

模块名称是可选的。如果Ans1Rng.Value = 0或Ans1Rng.Value = ""呢？我同意

我在.Display3DShading = True上得到一个错误。

Const RUNBOX_NAME = "RunBox"
On Error Resume Next
wks.Shapes.Range(RUNBOX_NAME).Delete
On Error GoTo 0
Set RunBoxRng = Ans1Rng.Offset(3, 3)
'Adds button to populate the rest of the questions
With RunBoxRng.Resize(3, 2)
    Set RunBox = wks.Buttons.Add(.Left, .Top, .Width, .Height)
End With
With RunBox
    .Name = RUNBOX_NAME
    .Characters.Text = "Answer All Questions to the Left Then Click Here"
    With .Characters(Start:=1, Length:=48).Font
        .FontStyle = "Bold"
        .Size = 12
    End With
    '.Display3DShading = True
    .OnAction = IIf(Ans1Rng.Value = 1, "Populate1HoodQs", "PopulateQuestions")
End With