2

ブックには、正常に機能する3つのマクロがあります。ただし、ワークシートのいずれかを保護すると、ワークシートは機能しなくなり、が表示されrun-time error 1004ます。

私はオンラインで見つけた2つの提案に従ってみました：

  • マクロコードの開始時に保護を解除し、終了時に保護します。
  • ユーザーインターフェイスのみ）が、実行時エラーは残ります。

ブックを保護する必要があり、マクロを機能させるにはどうすればよいですか？

マクロ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
4

2 に答える 2

5

マクロの開始時に保護を解除し、最後に再度保護するコードはありません。最初にこのようなものが必要です（これはすでに知っていると思いますが、明確にしようとしています）。

SheetName.Unprotect Password:=yourPassword

そして最後にこれ：

SheetName.Protect Password:=yourPassword

あなたはすでにこれを試したと言っていますが、投稿したコードからは、これらのコマンドがあった場所が明確ではありません。

この最後で動作を再現しようとするとhistoryWks、ロックとロック解除で問題が発生する可能性があると参照する 2 つの異なるワークシートがあることに気付きました。

1 つのオプションは、エントリ ポイントですべてのワークシートの保護を解除し、出口で再度保護することです。

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 = TrueMacro1

于 2012-10-17T12:39:35.463 に答える
0

マクロ初心者向けのヘルプ:

ボタンを使用してマクロを実行する場合は、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

"実行する必要があるマクロを入力してください

、最後に、 end sub の前に以下の行を貼り付けます

For Each sh In ActiveWorkbook.Worksheets
        sh.Protect Password:=yourPassword
    Next sh
于 2015-02-23T06:32:59.743 に答える