当工作表受保护时，宏不起作用。 正在运行的宏返回运行时错误1004

Question

我的工作簿中有三个可以正常工作的宏。 但是，当我保护任何工作表时，它们都停止工作，并且出现run-time error 1004 。

我尝试遵循在网上找到的两个建议：

• 在宏代码开始时取消保护，并在结束时进行保护；
• 仅限用户界面），但仍然存在运行时错误。

我需要保护我的工作簿，并使我的宏正常运行，我该怎么办？

宏1：

Sub Macro1()

Dim historyWks As Worksheet
Dim inputWks As Worksheet

Dim nextRow As Long
Dim oCol As Long

Dim myCopy As Range
Dim myTest As Range

Dim lRsp As Long

Set inputWks = Worksheets("Visit & Order Entry Form")
Set historyWks = Worksheets("Visit & Order Database")

'check for duplicate order ID in database
If inputWks.Range("CheckID2") = True Then
  lRsp = MsgBox("Clinic ID already in database. Update database?", vbQuestion + vbYesNo, "Duplicate ID")
  If lRsp = vbYes Then
    UpdateLogRecord
  Else
    MsgBox "Please change Clinic ID to a unique number."
  End If

Else

  'cells to copy from Input sheet - some contain formulas
  Set myCopy = inputWks.Range("OrderEntry2")

  With historyWks
      nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
  End With

  With inputWks
      Set myTest = myCopy.Offset(0, 2)

      If Application.Count(myTest) > 0 Then
          MsgBox "Please fill in all the cells!"
          Exit Sub
      End If
  End With

  With historyWks
      With .Cells(nextRow, "A")
          .Value = Now
          .NumberFormat = "mm/dd/yyyy hh:mm:ss"
      End With
      .Cells(nextRow, "B").Value = Application.UserName
      oCol = 3
      myCopy.Copy
      .Cells(nextRow, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
      Application.CutCopyMode = False
  End With

  'clear input cells that contain constants
  With inputWks
    On Error Resume Next
       With myCopy.Cells.SpecialCells(xlCellTypeConstants)
            .ClearContents
            Application.GoTo .Cells(1) ', Scroll:=True
       End With
    On Error GoTo 0
  End With
End If

End Sub

宏2

Sub UpdateLogWorksheet()

Dim historyWks As Worksheet
Dim inputWks As Worksheet

Dim nextRow As Long
Dim oCol As Long

Dim myCopy As Range
Dim myTest As Range

Dim lRsp As Long

Set inputWks = Worksheets("Visit & Order Entry Form")
Set historyWks = Worksheets("Contact Details & Segm Database")

'check for duplicate order ID in database
If inputWks.Range("CheckID") = True Then
  lRsp = MsgBox("Clinic ID already in database. Update database?", vbQuestion + vbYesNo, "Duplicate ID")
  If lRsp = vbYes Then
    UpdateLogRecord
  Else
    MsgBox "Please change Clinic ID to a unique number."
  End If

Else

  'cells to copy from Input sheet - some contain formulas
  Set myCopy = inputWks.Range("OrderEntry")

  With historyWks
      nextRow = .Cells(.Rows.Count, "A").End(xlUp).Offset(1, 0).Row
  End With

  With inputWks
      Set myTest = myCopy.Offset(0, 2)

      If Application.Count(myTest) > 0 Then
          MsgBox "Please fill in all the cells!"
          Exit Sub
      End If
  End With

  With historyWks
      With .Cells(nextRow, "A")
          .Value = Now
          .NumberFormat = "mm/dd/yyyy hh:mm:ss"
      End With
      .Cells(nextRow, "B").Value = Application.UserName
      oCol = 3
      myCopy.Copy
      .Cells(nextRow, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
      Application.CutCopyMode = False
  End With

  'clear input cells that contain constants
  With inputWks
    On Error Resume Next
       With myCopy.Cells.SpecialCells(xlCellTypeConstants)
            .ClearContents
            Application.GoTo .Cells(52) ', Scroll:=True
       End With
    On Error GoTo 0
  End With
End If

End Sub

宏3

Sub UpdateLogRecord()

Dim historyWks As Worksheet
Dim inputWks As Worksheet

Dim lRec As Long
Dim oCol As Long
Dim lRecRow As Long

Dim myCopy As Range
Dim myTest As Range

Dim lRsp As Long

Set inputWks = Worksheets("Visit & Order Entry Form")
Set historyWks = Worksheets("Contact Details & Segm Database")

'check for duplicate order ID in database
If inputWks.Range("CheckID") = False Then
  lRsp = MsgBox("Clinic ID not in database. Add clinic to database?", vbQuestion + vbYesNo, "New Order ID")
  If lRsp = vbYes Then
    UpdateLogWorksheet
  Else
    MsgBox "Please select Clinic ID that is in the database."
  End If

Else

  'cells to copy from Input sheet - some contain formulas
  Set myCopy = inputWks.Range("OrderEntry")

  lRec = inputWks.Range("CurrRec").Value
  lRecRow = lRec + 1

  With inputWks
      Set myTest = myCopy.Offset(0, 2)

      If Application.Count(myTest) > 0 Then
          MsgBox "Please fill in all the cells!"
          Exit Sub
      End If
  End With

  With historyWks
      With .Cells(lRecRow, "A")
          .Value = Now
          .NumberFormat = "mm/dd/yyyy hh:mm:ss"
      End With
      .Cells(lRecRow, "B").Value = Application.UserName
      oCol = 3

      myCopy.Copy
      .Cells(lRecRow, 3).PasteSpecial Paste:=xlPasteValues, Transpose:=True
      Application.CutCopyMode = False
  End With

  'clear input cells that contain constants
  With inputWks
    On Error Resume Next
       With myCopy.Cells.SpecialCells(xlCellTypeConstants)
            .ClearContents
            Application.GoTo .Cells(52) ', Scroll:=True
       End With
    On Error GoTo 0
  End With
End If

End Sub

Answer 1

您没有任何代码可以在宏的开头取消保护，然后在末尾再次进行保护。 您一开始就需要这样的东西（我想您已经知道了这一点，但是只是想清楚一点）。

SheetName.Unprotect Password:=yourPassword

最后是这样的：

SheetName.Protect Password:=yourPassword

您说您已经尝试过此操作，但是从您发布这些命令的位置的代码中尚不清楚。

通过尝试重现此行为，我注意到您有两个不同的工作表，您将它们称为historyWks ，这可能会导致锁定和解锁问题。

一种选择是在入口点取消保护所有工作表，然后在出口再次保护它们。

Private Const yourPassword As String = "password"

Sub UnprotectAll()
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Worksheets
        sh.Unprotect Password:=yourPassword
    Next sh
End Sub

Sub ProtectAll()
    Dim sh As Worksheet
    For Each sh In ActiveWorkbook.Worksheets
        sh.Protect Password:=yourPassword
    Next sh
End Sub

您只需要在Macro1的开始和结尾处调用它们。 您可能还希望在开始时添加Application.ScreenUpdating = False以避免闪烁，因为它在所有工作表中循环，然后在Macro1的末尾循环Application.ScreenUpdating = True 。

Answer 2

对宏初学者的帮助：

如果您使用按钮运行宏，则在subbuttonclick（）内部包含以下内容

Dim sh As Worksheet

Dim yourPassword As String

    yourPassword = "whatever password you like"

   For Each sh In ActiveWorkbook.Worksheets
        sh.Unprotect Password:=yourPassword

“现在输入您需要运行的宏

最后，在结束子之前，粘贴以下行

For Each sh In ActiveWorkbook.Worksheets
        sh.Protect Password:=yourPassword
    Next sh