Excel VBA根据单元格值密码锁定多个工作簿

Question

我有一个包含 400 个工作簿的文件夹。 我希望每个人都有不同的密码。 我发现了一些看起来应该可以工作的代码……但什么也没发生。

Sub YE_SetPassword()

Dim strFile As String
Dim strPath As String
Dim colFiles As New Collection
Dim i As Integer
Dim x As String
Dim ws As Worksheet

strPath = "C:\PATH"
strFile = Dir(strPath)

' Add Excel File Names to the variable colfiles
While strFile <> ""
    colFiles.Add strFile
    strFile = Dir
Wend

' Start reading colfiles collection and open workbooks one at a time
If colFiles.Count > 0 Then
    For i = 1 To colFiles.Count
        ActiveSheet.Cells(i, 1).Value = colFiles(i)
            Application.Workbooks.Open strPath & colFiles(i)
        Workbooks(colFiles(i)).Activate

' Once workbook is open search for Sheet2 and Sheet3 and if they are there, delete them
Application.DisplayAlerts = False
Err.Clear
On Error Resume Next
    Set ws = Sheets("Sheet2")
    ws.Delete
Err.Clear
On Error Resume Next
    Set ws = Sheets("Sheet3")
    ws.Delete
Application.DisplayAlerts = True

' Check cell value of A2 for name the assign a password based on that value
    x = Range("A2").Value
    Select Case x
    Case "LOOK FOR THIS NAME"
        pw = "USE THIS PWD"
    End Select

    ' Save the workbook with unique password
    ActiveWorkbook.SaveAs Filename:= _
        strPath & colFiles(i), FileFormat:= _
            xlOpenXMLWorkbook, Password:=pw, WriteResPassword:="", _
            ReadOnlyRecommended:=False, CreateBackup:=False
        ActiveWorkbook.Close True
    Next i
End If

End Sub

我不确定这里出了什么问题。 没有错误出现，但没有任何反应。 我确实尝试删除一些步骤，仍然没有。 有什么建议？ 希望不必手动锁定这些，即使编写 Case 语句很痛苦。

或者，是否有某种方法可以将宏指向查找表并让它根据查找选择密码？ 我正在查找 ID# 的最后 4 个名称和锁定表。

Answer 1

上面的代码确实有效。 我在路径中犯了一个错误，省略了最后的“\\”。 感谢 Chris Neilsen 和 BigBen 为我指明了正确的方向！

编辑：也就是说，随着我在这方面的工作越来越多，我找到了一种更简单的方法来解决它。 下面是根据在当前活动工作簿中查找值来锁定和解锁充满工作簿的文件夹的代码。

Sub LockFolder()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Page1")
Dim Loc As String: Loc = "C:\PATH\"
Dim pw As String, fn As String, cb As Workbook, i As Long

'Loc = Local Location
'pw = Password
'fn = File Name
'cb = Current Book

Application.ScreenUpdating = False
Application.DisplayAlerts = False
    For i = 2 To ws.Range("A" & ws.Rows.Count).End(xlUp).Row
        On Error Resume Next 'If book does not exist
            fn = Loc & ws.Range("A" & i)
            pw = ws.Range("B" & i)

            Set cb = Workbooks.Open(fn, Password:="")

            cb.SaveAs fn, Password:=pw
            cb.Close False 'You just saved the book above, no need for TRUE
        On Error GoTo 0
    Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub


Sub Unlock_folder()

Dim ws As Worksheet: Set ws = ThisWorkbook.Sheets("Page1")
Dim Loc As String: Loc = "C:\PATH\"
Dim pw As String, fn As String, cb As Workbook, i As Long

'Loc = Local Location
'pw = Password
'fn = File Name
'cb = Current Book

Application.ScreenUpdating = False
Application.DisplayAlerts = False
    For i = 2 To ws.Range("A" & ws.Rows.Count).End(xlUp).Row
        On Error Resume Next 'If book does not exist
            fn = Loc & ws.Range("A" & i)
            pw = ws.Range("B" & i)

            Set cb = Workbooks.Open(fn, Password:=pw)

            cb.SaveAs fn, Password:=""
            cb.Close False 'You just saved the book above, no need for TRUE
        On Error GoTo 0
    Next i
Application.ScreenUpdating = True
Application.DisplayAlerts = True

End Sub