时间戳

首页 > 解决方案 > VBA/宏：如何拆分 excel 工作表并使用不同的密码保护每张工作表？

excel - VBA/宏：如何拆分 excel 工作表并使用不同的密码保护每张工作表？

问题描述

我有一个将工作表拆分为不同工作簿的代码，我正在尝试修改此代码，以便每个文件在保存之前都受到密码保护。

这是员工的工资数据，每个月都需要发送给员工，所以这个“主文件”是我每个月都会更新的，然后我需要 VBA 来拆分这些工作表（工资单）并用密码保护它们他们的出生日期为 DDMMYYYY 格式（因此每个月都使用相同的密码），然后我可以通过电子邮件将其转发给他们。

代码：

Sub SplitEachWorksheet()
    Dim FPath As String
    FPath = Application.ActiveWorkbook.Path

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    For Each ws In ThisWorkbook.Sheets
        ws.Copy
        Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws.Name & ".xlsx"
        Application.ActiveWorkbook.Close False
    Next

    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
End Sub

标签： excelvba

解决方案

更新

要执行密码表的查找，然后将相应的密码分配给表，您可以使用如下函数：

Function fn_GetPassword(str_SheetName As String) As String

On Error GoTo Err
    fn_GetPassword = Application.VLookup(str_SheetName, Sheets("Passwords").Range("A:B"), 2, 0)
    Exit Function

Err: '' Error handling if lookup value not found, return blank string
    fn_GetPassword = ""
    Debug.Print ("No allocated password found for: " & str_SheetName) '' Show debug for missing sheet password

End Function

然后像这样使用它：

Sub SplitEachWorksheet()
 
Dim FPath As String
FPath = Application.ActiveWorkbook.Path

Application.ScreenUpdating = False
Application.DisplayAlerts = False
Dim str_tmpPW As String
 
For Each ws In ThisWorkbook.Sheets
    If ws.Name <> "Passwords" Then '' Do no save worksheet with all the passwords
        str_tmpPW = fn_GetPassword(ws.Name) '' Store password in temp variable
        If str_tmpPW <> "" Then '' Do not save workbook if no password set
            ws.Copy
            Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws.Name & ".xlsx", Password:=str_tmpPW
            Application.ActiveWorkbook.Close False
        End If
    End If
Next
 
Application.DisplayAlerts = True
Application.ScreenUpdating = True
   
End Sub

密码表可能如下所示：

密码表

显然根据需要调整您的代码。可以对代码进行更多调整以将外部工作簿考虑在内，但对于您的需要，它应该就足够了。然后，您需要考虑如何保护现有工作簿的安全，a) 因为您要存储薪水，b) 因为您要存储密码。但这是超出此查询范围的问题。

你非常亲近。

只需要在 SaveAs 参数中添加一个额外的限定符：

Password:="test"

看起来像这样：

Sub SplitEachWorksheet()
 
Dim FPath As String
FPath = Application.ActiveWorkbook.Path

Application.ScreenUpdating = False
Application.DisplayAlerts = False
 
For Each ws In ThisWorkbook.Sheets
    ws.Copy
    Application.ActiveWorkbook.SaveAs Filename:=FPath & "\" & ws.Name & ".xlsx", Password:="test"
    Application.ActiveWorkbook.Close False
 
Next
 
Application.DisplayAlerts = True
Application.ScreenUpdating = True
   
End Sub

您显然需要使用变量而不是“测试”。

我想您有一个与每张纸相关联的 DOB 列表？因此，您可以使用该列表。

推荐阅读