OnAction运行时错误＆＃34; 1004＆＃34;在初次运行

时间：2017-01-11 03:12:08

标签： excel vba excel-vba

背景：我有一本记录奥林匹克举重/历史记录的工作簿。用户可以通过按下一个按钮（添加新电梯）来创建新的电梯，该按钮调用一个宏＆＃34; New_Lift＆＃34;和＆＃34; Create_Button＆＃34;。这将创建一个带有电梯名称的新工作表，在主页上使用电梯的名称创建一个新列，添加一个名为＆＃34;日志历史记录＆＃34; （OnAction =新工作表子）。

新工作表，列和按钮创建正常，但收到运行时错误＆＃34; 1004＆＃34;打开工作簿后第一次运行宏时（此后工作正常）。该错误指向＆＃39; .OnAction＆＃39;的按钮。下面是主要表格和＆＃34; Create_Button＆＃34;码。非常感谢任何帮助，如果我需要澄清任何问题，请告诉我。

工作簿截图

Workbook Screenshot 

Sub Add_New_Lift()

'*****************************************************************************************************
' This macro creates a new columns that contains the lift name, "Current", "Goal", "% Goal" and formulas
'*****************************************************************************************************
Dim ecol As Integer
Dim erow As Integer
Dim NewLift As String
Dim Lift_Metcon As String
Dim SheetCodeName As String

Application.ScreenUpdating = False

'Ask user to provide the name of the lift through a message box
NewLift = InputBox("New Lift Name:", "Add New Lift")

If StrPtr(NewLift) = 0 Then
    Exit Sub
Else
    Do
    Lift_Metcon = InputBox("Is this a Lift (Weight), Metcon (Time), or AMRAP (Total Reps):" & _
                    vbCrLf & vbTab & "-   Lift" & _
                    vbCrLf & vbTab & "-   Metcon" & _
                    vbCrLf & vbTab & "-   AMRAP" _
                    , "Type of Measurement")

    If StrPtr(Lift_Metcon) = 0 Then
        Exit Sub
    ElseIf (Lift_Metcon = "Lift") Or (Lift_Metcon = "Metcon") Or (Lift_Metcon = "AMRAP") Then
        Exit Do
    Else
        MsgBox "You have not made a valid entry.  Please try again."
    End If
    Loop
End If

'Find first empty column to add the new lift and formatting as well as Column letters for use with formula
ecol = Worksheets("Main").Cells(4, Columns.Count).End(xlToLeft).Offset(0, 1).Column
ColNo1 = ecol
ColLet1 = Split(Cells(, ColNo1).Address, "$")(1)
ColNo2 = ecol + 1
ColLet2 = Split(Cells(, ColNo2).Address, "$")(1)
ColNo3 = ecol + 2
ColLet3 = Split(Cells(, ColNo3).Address, "$")(1)


'Formatting
    Worksheets("Main").Activate
    Columns(ecol).Select
    Selection.Borders(xlEdgeLeft).LineStyle = xlContinuous
    Selection.Borders(xlEdgeLeft).Weight = xlMedium
    Range(Cells(3, ecol), Cells(3, ecol + 2)).Merge
    Cells(3, ecol) = NewLift
    Cells(3, ecol).Font.Size = 16
    Cells(4, ecol) = "Current"
    Cells(4, ecol + 1) = "Goal"
    Cells(4, ecol + 2) = "% Goal"
    Range(Cells(3, ecol), Cells(4, ecol + 2)).HorizontalAlignment = xlCenter
    Range(Cells(3, ecol), Cells(4, ecol + 2)).Font.Bold = True
    Range(Cells(3, ecol), Cells(4, ecol + 2)).ColumnWidth = 8
    Range(Cells(1, ecol), Cells(4, ecol + 2)).Interior.Color = RGB(166, 166, 166)
    Range(Cells(5, ecol + 2), Cells(100, ecol + 2)).Formula = "=IF(" & ColLet1 & "5<> """", " & ColLet1 & "5/" & ColLet2 & "5,"""" )"
    Range(Cells(5, ecol + 2), Cells(100, ecol + 2)).NumberFormat = "0.00%"

    If Lift_Metcon = "Metcon" Then
        Range(Cells(5, ecol), Cells(100, ecol)).NumberFormat = "0.0"
    End If

'Create new worksheet with formatting
Sheets.Add(After:=Sheets(Sheets.Count)).Name = NewLift
Sheets(NewLift).Range("A2") = "Name"
Sheets(NewLift).Range("A1") = Lift_Metcon
Sheets(NewLift).Range("A1").Font.Color = RGB(166, 166, 166)
Sheets(NewLift).Range("A2:B2").Font.Bold = True
Sheets(NewLift).Range("A:A").ColumnWidth = 27
Sheets(NewLift).Range("A1:BZ2").Interior.Color = RGB(166, 166, 166)
Sheets(NewLift).Range("A1").RowHeight = 55
Sheets(NewLift).Range("B2") = "M/F"
Sheets(NewLift).Columns("C").Select
ActiveWindow.FreezePanes = True
Sheets(NewLift).Range("A3").Select

For Each Cell In Range("A3:BZ100") ''change range accordingly
If Cell.Row Mod 2 = 1 Then ''highlights row 2,4,6 etc|= 0 highlights 1,3,5
    Cell.Interior.Color = RGB(217, 217, 217) ''color to preference
Else
    Cell.Interior.ColorIndex = xlNone ''color to preference or remove
End If
Next Cell

SheetCodeName = ActiveSheet.CodeName

'Calls the CreateButton subroutine and passes the NewLift from user, last empty column and SheetCodeName (i.e. Sheet5)
Call CreateButton(NewLift, ecol, SheetCodeName)

Worksheets("Records").Activate
erow = Worksheets("Records").Cells(Rows.Count, 1).End(xlUp).Offset(1).Row
Cells(erow, 1) = NewLift

Worksheets("Main").Activate
Range("A5").Select

Application.ScreenUpdating = True

End Sub



Sub CreateButton(NewLift As String, ecol As Integer, SheetCodeName As String)
Dim Code As String
Dim NewLiftSpace As String

NewLiftSpace = Replace(NewLift, " ", "_")
SheetCodeName = Worksheets(NewLift).CodeName

With ActiveSheet 'Main Sheet
    .Buttons.Add(Cells(2, ecol + 1).Left, Cells(2, ecol + 1).Top, 45, 45).Select
    Selection.Characters.Text = "Log" & vbCrLf & "History"
    Selection.OnAction = SheetCodeName & "." & NewLiftSpace & "_Button"
End With

'subroutine macro text
Code = "Public Sub " & NewLiftSpace & "_Button()" & vbCrLf
Code = Code & "Dim LiftSheet As String" & vbCrLf
Code = Code & "LiftSheet = " & """" & NewLift & """" & vbCrLf
Code = Code & "Call History.Log_History(LiftSheet)" & vbCrLf
Code = Code & "End Sub" & vbCrLf
Code = Code & "Public Sub CommandButton1_Click()" & vbCrLf
Code = Code & "UserForm1.Show" & vbCrLf
Code = Code & "Athlete_Chart(Athlete)" & vbCrLf
Code = Code & "End Sub"


'add macro at the end of the sheet module
With ActiveWorkbook.VBProject.VBComponents(ActiveSheet.CodeName).CodeModule
    .InsertLines .CountOfLines + 1, Code
End With

End Sub

编辑：如果VBA编辑器处于打开状态，代码运行时没有错误。

1 个答案:

答案 0 :(得分：1)

这是因为在Sheets.Add(...后，新工作表成为 Active ，而在CreateButton()语句中成为<{1}}语句：

With ActiveSheet 'Main Sheet

实际上是引用新添加的工作表，而不是您预期的“主要”工作表

最重要的是，尽可能避免使用Activate / ActiveXXX / Select / Selection编码模式，并使用完全限定的范围引用，如下面的代码重构一样：

Option Explicit

Sub Add_New_Lift()

    '*****************************************************************************************************
    ' This macro creates a new columns that contains the lift name, "Current", "Goal", "% Goal" and formulas
    '*****************************************************************************************************
    Dim ecol As Integer, ColNo1 As Integer, ColNo2 As Integer, ColNo3 As Integer
    Dim ColLet1 As String, ColLet2 As String, ColLet3 As String
    Dim erow As Integer
    Dim NewLift As String
    Dim Lift_Metcon As String
    Dim SheetCodeName As String
    Dim cell As Range

    Application.ScreenUpdating = False
    On Error GoTo errHandler
    'Ask user to provide the name of the lift through a message box
    NewLift = InputBox("New Lift Name:", "Add New Lift")

    If StrPtr(NewLift) = 0 Or NewLift = "" Then Exit Sub
    Do
        Lift_Metcon = InputBox("Is this a Lift (Weight), Metcon (Time), or AMRAP (Total Reps):" & _
                        vbCrLf & vbTab & "-   Lift" & _
                        vbCrLf & vbTab & "-   Metcon" & _
                        vbCrLf & vbTab & "-   AMRAP" _
                        , "Type of Measurement")
        If StrPtr(Lift_Metcon) = 0 Then Exit Sub
    Loop While Not ((Lift_Metcon = "Lift") Or (Lift_Metcon = "Metcon") Or (Lift_Metcon = "AMRAP"))

    'Find first empty column to add the new lift and formatting as well as Column letters for use with formula
    With Worksheets("Main") '<--| reference your "Main" sheet
        ecol = .Cells(4, Columns.Count).End(xlToLeft).Offset(0, 1).Column
        ColNo1 = ecol
        ColLet1 = Split(.Cells(, ColNo1).Address, "$")(1)
        ColNo2 = ecol + 1
        ColLet2 = Split(.Cells(, ColNo2).Address, "$")(1)
        ColNo3 = ecol + 2
        ColLet3 = Split(.Cells(, ColNo3).Address, "$")(1)

        'Formatting
        With .Columns(ecol) '<--| reference referenced sheet 'ecol'th column
            .Borders(xlEdgeLeft).LineStyle = xlContinuous
            .Borders(xlEdgeLeft).Weight = xlMedium
        End With
        .Range(.Cells(3, ecol), .Cells(3, ecol + 2)).Merge
        .Cells(3, ecol) = NewLift
        .Cells(3, ecol).Font.Size = 16
        .Cells(4, ecol) = "Current"
        .Cells(4, ecol + 1) = "Goal"
        .Cells(4, ecol + 2) = "% Goal"
        .Range(.Cells(3, ecol), .Cells(4, ecol + 2)).HorizontalAlignment = xlCenter
        .Range(.Cells(3, ecol), .Cells(4, ecol + 2)).Font.Bold = True
        .Range(.Cells(3, ecol), .Cells(4, ecol + 2)).ColumnWidth = 8
        .Range(.Cells(1, ecol), .Cells(4, ecol + 2)).Interior.Color = RGB(166, 166, 166)
        .Range(.Cells(5, ecol + 2), .Cells(100, ecol + 2)).Formula = "=IF(" & ColLet1 & "5<> """", " & ColLet1 & "5/" & ColLet2 & "5,"""" )"
        .Range(.Cells(5, ecol + 2), .Cells(100, ecol + 2)).NumberFormat = "0.00%"
        If Lift_Metcon = "Metcon" Then .Range(.Cells(5, ecol), .Cells(100, ecol)).NumberFormat = "0.0"

        'Create new worksheet with formatting
        With Sheets.Add(After:=Sheets(Sheets.Count)) '<--| this will make the new sheet the "Active" one
            .Name = NewLift
            .Range("A2") = "Name"
            .Range("A1") = Lift_Metcon
            .Range("A1").Font.Color = RGB(166, 166, 166)
            .Range("A2:B2").Font.Bold = True
            .Range("A:A").ColumnWidth = 27
            .Range("A1:BZ2").Interior.Color = RGB(166, 166, 166)
            .Range("A1").RowHeight = 55
            .Range("B2") = "M/F"
            .Columns("C").Select
            ActiveWindow.FreezePanes = True

            For Each cell In .Range("A3:BZ100") ''change range accordingly
                If cell.Row Mod 2 = 1 Then ''highlights row 2,4,6 etc|= 0 highlights 1,3,5
                    cell.Interior.Color = RGB(217, 217, 217) ''color to preference
                Else
                    cell.Interior.ColorIndex = xlNone ''color to preference or remove
                End If
            Next cell
            SheetCodeName = .CodeName

        End With
        .Activate '<--| jump back to referenced (i.e.: "Main") sheet and make it active again

        'Calls the CreateButton subroutine and passes the NewLift from user, last empty column and SheetCodeName (i.e. Sheet5)
        CreateButton NewLift, ecol, SheetCodeName

    End With
    Worksheets("Records").Cells(Rows.Count, 1).End(xlUp).Offset(1).Value = NewLift

errHandler:
    Application.ScreenUpdating = True

End Sub



Sub CreateButton(NewLift As String, ecol As Integer, SheetCodeName As String)
    Dim Code As String
    Dim NewLiftSpace As String

    NewLiftSpace = Replace(NewLift, " ", "_")
    SheetCodeName = Worksheets(NewLift).CodeName

    With ActiveSheet.Buttons.Add(Cells(2, ecol + 1).Left, Cells(2, ecol + 1).Top, 45, 45) '<--| reference a new button on active sheet
        .Characters.Text = "Log" & vbCrLf & "History"
        .OnAction = SheetCodeName & "." & NewLiftSpace & "_Button"
    End With

    'subroutine macro text
    Code = "Public Sub " & NewLiftSpace & "_Button()" & vbCrLf
    Code = Code & "Dim LiftSheet As String" & vbCrLf
    Code = Code & "LiftSheet = " & """" & NewLift & """" & vbCrLf
    Code = Code & "Call History.Log_History(LiftSheet)" & vbCrLf
    Code = Code & "End Sub" & vbCrLf
    Code = Code & "Public Sub CommandButton1_Click()" & vbCrLf
    Code = Code & "UserForm1.Show" & vbCrLf
    Code = Code & "Athlete_Chart(Athlete)" & vbCrLf
    Code = Code & "End Sub"

    'add macro at the end of the sheet module
    With ActiveWorkbook.VBProject.VBComponents(SheetCodeName).CodeModule '<--| reference your new sheet 'CodeName'
        .InsertLines .CountOfLines + 1, Code
    End With

End Sub

我的deliberatley选择离开那个：

.Activate '<--| jump back to referenced (i.e.: "Main") sheet and make it active again

因为我打算你需要让用户将“主要”表格作为活动表格

所以我也利用它在CreateButton（）中留下ActiveSheet引用来隐式引用“Main”表而不是更改Sub 签名添加一个新参数（对“Main”的引用“表格或其名称”使用和引用“主要”表格

相关问题
最新问题