我有一个宏程序可以拆分文件并保护工作表，但我无法在单个工作簿中进行自动过滤和排序

Question

我有一个宏程序，可以解析工作表并根据一个特定的列创建新的工作簿。就我而言，将根据第 3 列创建新的工作簿。我还编写了一个调用函数来使用密码保护各个工作簿。只有少数列是可编辑的，其余列是只读的。现在我想应用自动过滤和排序功能，以便用户可以根据需要搜索信息并在可编辑单元格中输入值。但是，当我们保护工作表时，自动过滤器不起作用。您能否帮助在每个单独的工作簿的受保护工作表上添加自动过滤功能。显示的示例代码以供参考。

Sub parse_data()
Dim lr As Long
Dim ws As Worksheet
Dim vcol, i As Integer
Dim icol As Long
Dim myarr As Variant
Dim title As String
Dim titlerow As Integer

vcol = 3
Set ws = Sheets("Sheet1")
lr = ws.Cells(ws.Rows.Count, vcol).End(xlUp).Row
title = "A1:Z1"
titlerow = ws.Range(title).Cells(1).Row
icol = ws.Columns.Count
ws.Cells(1, icol) = "Unique"
For i = 2 To lr
On Error Resume Next
If ws.Cells(i, vcol) <> "" And Application.WorksheetFunction.Match(ws.Cells(i, vcol), ws.Columns(icol), 0) = 0 Then
ws.Cells(ws.Rows.Count, icol).End(xlUp).Offset(1) = ws.Cells(i, vcol)
End If
Next
myarr = Application.WorksheetFunction.Transpose(ws.Columns(icol).SpecialCells(xlCellTypeConstants))
ws.Columns(icol).Clear
For i = 2 To UBound(myarr)
ws.Range(title).AutoFilter field:=vcol, Criteria1:=myarr(i) & ""
If Not Evaluate("=ISREF('" & myarr(i) & "'!A1)") Then
'===================================================================
'~~Sheets.Add(after:=Worksheets(Worksheets.Count)).Name = myarr(i) & ""
Workbooks.Add
ActiveWorkbook.Sheets.Add(0).Name = myarr(i) & ""
'===================================================================
Else
Sheets(myarr(i) & "").Move after:=Worksheets(Worksheets.Count)
End If
'==========================================================================
'~~ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy Sheets(myarr(i) & "").Range("A1")
'~~Sheets(myarr(i) & "").Columns.AutoFit
ws.Range("A" & titlerow & ":A" & lr).EntireRow.Copy ActiveWorkbook.Sheets("Sheet1").Range("A1")
'mainworkBook.Sheets(1).Range("T2:T1000").Formula = "=SUM(Q2:S2)"
ActiveWorkbook.SaveAs "C:MacrosSplit_Files" & myarr(i) & ".xlsx"
'=========================================================================
ActiveWorkbook.Close
Next
ws.AutoFilterMode = False
ws.Activate
Call ProtectAll
End Sub

Sub ProtectAll()
Dim wBk As Workbook
Dim sFileSpec As String
Dim sPathSpec As String
Dim sFoundFile As String
Dim mainworkBook As Workbook
Dim ws1 As Worksheet
Dim LastRow As Long
sPathSpec = "C:MacrosSplit_Files"
sFileSpec = "*.xlsx"
sFoundFile = Dir(sPathSpec & sFileSpec)
Do While sFoundFile <> ""
Set wBk = Workbooks.Open(sPathSpec & sFoundFile)
With wBk
Set mainworkBook = wBk
'mainworkBook.Sheets(1).Unprotect passowrd = "abc"
Set ws1 = mainworkBook.Sheets(1)
LastRow = ws1.Cells(ws1.Rows.Count, "U").End(xlUp).Row
mainworkBook.Sheets(1).Range("U2:U" & LastRow).Formula = "=SUM(R2:T2)"


'mainworkBook.Sheets(1).Range("A:Z").Locked = True
'mainworkBook.Sheets(1).Range("A1:Z1").Locked = False
'mainworkBook.Sheets(1).Range("Q:S").Locked = False
'mainworkBook.Sheets(1).Range("U:U").Locked = False
'mainworkBook.Sheets(1).Range("W:X").Locked = False
mainworkBook.Worksheets("Sheet1").Cells.EntireColumn.AutoFit
'mainworkBook.Sheets(1).Protect passowrd = "abc"
'mainworkBook.Sheets(1).Protect passowrd:="abc", userinterfaceonly:=True
'mainworkBook.Sheets(1).EnableOutlining = True
'mainworkBook.Sheets(1).EnableAutoFilter = True
'mainworkBook.Sheets(1).EnableSelection = xlUnlockedCells

Worksheets(2).Visible = xlSheetHidden
Worksheets(3).Visible = xlSheetHidden

Application.DisplayAlerts = False
wBk.SaveAs Filename:=.FullName
Application.DisplayAlerts = True
End With
Set wBk = Nothing
Workbooks(sFoundFile).Close False
sFoundFile = Dir
Loop
End Sub

问候 利努

Answer 1

为了在受保护的工作表中进行排序，您必须取消保护它，然后再次保护它。 但是，即使工作表受到保护，您也可以使用过滤功能，只是不排序。

以下是我在项目中使用的两个小函数：

Function protect_sheet(sheetname As String)
If Sheets(sheetname).ProtectContents = False Then
Sheets(sheetname).Protect Password:=Password, DrawingObjects:=True, Contents:=True, Scenarios:=True, AllowSorting:=True, AllowFiltering:=True
End If
End Function
Function unprotect_sheet(sheetname As String)
If Sheets(sheetname).ProtectContents = True Then
Sheets(sheetname).Unprotect Password:=Password
End If
End Function