Macros don't work when sheet is protected. Running macro returns run-time error 1004

2
votes

I have three macros in my workbook that work fine. However, when I protect any of the worksheets, they stop to work and I get a run-time error 1004.

I have tried following the two suggestions that I found online:

  • Unprotect at start of macro code, and protect at end;
  • User Interface Only) but the run-time error remains.

I need my Workbook to be protected and for my macros to function, what shall I do?

Macro 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

Macro 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

Macro 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
2
excelvba
Post your code. Unprotecting then protecting should work – brettdj
Thanks for responding. I think it should work indeed, but since this is the first time I am dealing with codes I may be doing something wrong. – Miles

2 Answers

5
votes

You don't have any code in there to unprotect at the start of the macro and then protect again at the end. You need something like this at the start (I think you already know this but just trying to be clear).

SheetName.Unprotect Password:=yourPassword

And this at the end:

SheetName.Protect Password:=yourPassword

You say you've tried this already but it's not clear from the code you posted where you had these commands.

From trying to reproduce the behaviour at this end I notice you have two different worksheets you refer to as historyWks which could be causing problems with locking and unlocking.

One option is to unprotect all worksheets at your entry point then protect them again at the exit.

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

You just need to call these at the start and end of your Macro1. You might also want to add an Application.ScreenUpdating = False at the start to avoid flicker as it loops through all the worksheets and then Application.ScreenUpdating = True at the end of Macro1.

0
votes

help for macro beginners:

if you are using a button to run a macro, include the following inside sub buttonclick()

Dim sh As Worksheet

Dim yourPassword As String

    yourPassword = "whatever password you like"

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

"now enter your macro which needs to be run

,at the end , before end sub paste the below line

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