![](/img/trans.png)
[英]Split data into multiple workbooks based on cell value in Excel using vba
[英]Excel VBA to password lock multiple workbooks based on cell value
我有一個包含 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 個名稱和鎖定表。
上面的代碼確實有效。 我在路徑中犯了一個錯誤,省略了最后的“\\”。 感謝 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
聲明:本站的技術帖子網頁,遵循CC BY-SA 4.0協議,如果您需要轉載,請注明本站網址或者原文地址。任何問題請咨詢:yoyou2525@163.com.