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以避免闪烁，因为它遍历所有工作表，然后Application.ScreenUpdating = True结束Macro1。

Answer 2

帮助宏初学者：

如果您使用按钮运行宏，包括以下内部子按钮单击（）

Dim sh As Worksheet

Dim yourPassword As String

    yourPassword = "whatever password you like"

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

＆＃34;现在输入需要运行的宏

，最后，在结束之前粘贴下面一行

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

当纸张受到保护时，宏不起作用。运行宏返回运行时错误1004

2 个答案: