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

时间：2016-08-02 22:58:20

标签： excel-vba error-handling vba excel

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

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

    4. 如果我从模块本身运行它，按钮被分配的代码可以工作。如果我从按钮运行它，它不会跟随辅助子调用（示例：它将“Hood 1”添加到范围值，就像它应该，但它然后它没有跟随宏调用格式化“引擎盖1”下列出的列

    添加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

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

1 个答案:

答案 0 :(得分：0)

我同意蒂姆威廉姆斯;问题可能在于 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
相关问题
最新问题