Excel VBA 错误从控制表单框中调用 Sub

Question

我正在 VBA 中构建一个非常匆忙的多层宏，它应该执行以下操作:

用户在起始表上选择数字 1-4；额外的工作表 1 - 4 出现并调用第一个模块来格式化工作表(成功运行)

用户导航到 4 个工作表中的第一个并回答问题 1，然后填充 2-4(成功)

用户填写问题 2-4(可能更多取决于标准)并单击按钮(控制表单，非 active-x)以从另一个子运行宏(这是失败的地方)

如果我从模块本身运行它，则分配给按钮的代码可以工作。如果我从按钮运行它，它不会跟随辅助子调用(例如:它将“Hood 1”添加到应有的范围值，但随后它不会跟进宏调用格式化“Hood 1”下列出的列

添加运行框:

    '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

我已经以各种/光荣的失败形式上传了它的副本。 Uploaded here

Answer 1

我同意蒂姆·威廉姆斯的观点；问题可能出在 Populate1HoodQs 和 填充问题 .我测试了代码，没有任何问题。您是否尝试在 中设置断点？ Populate1HoodQs 和 填充问题 看看他们是否真的被调用？

模块名称是可选的。如果 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