☰

如何使用宏用多个密码保护多个 Excel 2007 文件？

tag-icon • tag-icon microsoft-excel microsoft-excel-2007 vba
如何使用宏用多个密码保护多个 Excel 2007 文件？

我是新来的，所以如果我的帖子不正确或类似情况，请告诉我。

我目前有一个宏，可以将一个 excel 文件拆分为多个文件并分别保存。这一步我找到了答案，并且非常满意。

我需要对这些文件进行密码保护，这样当我通过电子邮件将它们发送给客户时，我就会觉得它们是安全传输的。是否有一个宏可以编写/使用来完成这个技巧。

我的 Excel 文件标签 1 包含我的所有数据，目前根据 A 列拆分出所有内容。

John Test1
John Test2
John Test3
Alex Test4
Alex Test5
Frank Test6
Frank Test7

我使用的宏将其拆分为 John/Alex/Frank 的单独文件，该文件仅显示他们的数据，而不显示其他个人数据。

我还有标签 2，里面保存着所有的密码：

John Pw1
Alex Pw2
Frank Pw3

我正在寻找一种方法，让选项卡 2 中列出的密码在当前宏的过程中应用于新创建的文档。

任何帮助都将不胜感激。如果我问的问题有任何不清楚的地方，请告诉我。

作为参考，我将引用我从用户 mtone 那里找到的代码，因为这是我目前正在使用的代码。这个代码对我非常有用，我非常感谢 mtone 发布它。我不认为我可以给 mtone 发送私人消息，但如果可以的话，我会非常感谢他！

    Public Sub SplitToFiles()

    ' MACRO SplitToFiles
    ' Last update: 2012-03-04
' Author: mtone
' Version 1.1
' Description:
' Loops through a specified column, and split each distinct values into a separate file by making a copy and deleting rows below and above
'
    ' Note: Values in the column should be unique or sorted.
'
' The following cells are ignored when delimiting sections:
' - blank cells, or containing spaces only
' - same value repeated
' - cells containing "total"
'
' Files are saved in a "Split" subfolder from the location of the source workbook, and named after the section name.

Dim osh As Worksheet ' Original sheet
Dim iRow As Long ' Cursors
Dim iCol As Long
Dim iFirstRow As Long ' Constant
Dim iTotalRows As Long ' Constant
Dim iStartRow As Long ' Section delimiters
Dim iStopRow As Long
Dim sSectionName As String ' Section name (and filename)
Dim rCell As Range ' current cell
Dim owb As Workbook ' Original workbook
Dim sFilePath As String ' Constant
Dim iCount As Integer ' # of documents created

iCol = Application.InputBox("Enter the column number used for splitting", "Select column", 2, , , , , 1)
iRow = Application.InputBox("Enter the starting row number (to skip header)", "Select row", 5, , , , , 1)
iFirstRow = iRow

Set osh = Application.ActiveSheet
Set owb = Application.ActiveWorkbook
iTotalRows = osh.UsedRange.Rows.Count
sFilePath = Application.ActiveWorkbook.Path

If Dir(sFilePath + "\Split", vbDirectory) = "" Then
MkDir sFilePath + "\Split"
End If

'Turn Off Screen Updating  Events
Application.EnableEvents = False
Application.ScreenUpdating = False

Do
' Get cell at cursor
Set rCell = osh.Cells(iRow, iCol)
sCell = Replace(rCell.Text, " ", "")

If sCell = "" Or (rCell.Text = sSectionName And iStartRow <> 0) Or InStr(1, rCell.Text, "total", vbTextCompare) <> 0 Then
    ' Skip condition met
Else
    ' Found new section
    If iStartRow = 0 Then
        ' StartRow delimiter not set, meaning beginning a new section
        sSectionName = rCell.Text
        iStartRow = iRow
    Else
        ' StartRow delimiter set, meaning we reached the end of a section
        iStopRow = iRow - 1

        ' Pass variables to a separate sub to create and save the new worksheet
        CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
        iCount = iCount + 1

        ' Reset section delimiters
        iStartRow = 0
        iStopRow = 0

        ' Ready to continue loop
        iRow = iRow - 1
    End If
End If

' Continue until last row is reached
If iRow < iTotalRows Then
        iRow = iRow + 1
Else
    ' Finished. Save the last section
    iStopRow = iRow
    CopySheet osh, iFirstRow, iStartRow, iStopRow, iTotalRows, sFilePath, sSectionName, owb.fileFormat
    iCount = iCount + 1

    ' Exit
    Exit Do
End If
Loop

'Turn On Screen Updating  Events
Application.ScreenUpdating = True
Application.EnableEvents = True

       MsgBox Str(iCount) + " documents saved in " + sFilePath


End Sub

Public Sub DeleteRows(targetSheet As Worksheet, RowFrom As Long, RowTo As Long)

    Dim rngRange As Range
Set rngRange = Range(targetSheet.Cells(RowFrom, 1), targetSheet.Cells(RowTo, 1)).EntireRow
rngRange.Select
rngRange.Delete

End Sub


Public Sub CopySheet(osh As Worksheet, iFirstRow As Long, iStartRow As Long, iStopRow As Long, iTotalRows As Long, sFilePath As String, sSectionName As String, fileFormat As XlFileFormat)
 Dim ash As Worksheet ' Copied sheet
 Dim awb As Workbook ' New workbook

 ' Copy book
 osh.Copy
 Set ash = Application.ActiveSheet

 ' Delete Rows after section
 If iTotalRows > iStopRow Then
     DeleteRows ash, iStopRow + 1, iTotalRows
 End If

 ' Delete Rows before section
 If iStartRow > iFirstRow Then
     DeleteRows ash, iFirstRow, iStartRow - 1
 End If

 ' Select left-topmost cell
 ash.Cells(1, 1).Select

 ' Clean up a few characters to prevent invalid filename
 sSectionName = Replace(sSectionName, "/", " ")
 sSectionName = Replace(sSectionName, "\", " ")
 sSectionName = Replace(sSectionName, ":", " ")
 sSectionName = Replace(sSectionName, "=", " ")
 sSectionName = Replace(sSectionName, "*", " ")
 sSectionName = Replace(sSectionName, ".", " ")
 sSectionName = Replace(sSectionName, "?", " ")

 ' Save in same format as original workbook
 ash.SaveAs sFilePath + "\Split\" + sSectionName, fileFormat

 ' Close
 Set awb = ash.Parent
 awb.Close SaveChanges:=False
End Sub

答案1

我需要对这些文件进行密码保护，这样当我通过电子邮件将它们发送给客户时，我会感觉到它们正在被安全传输。

密码保护的 Excel 文件不应被视为安全。网上有多种破解此类文档的选项，甚至较新版本的 Excel 仍存在安全漏洞。如果文件包含敏感数据，则应考虑其他类型的加密，例如前列腺特发性硬化症。

相关内容