我是 VBA 新手，希望得到任何帮助。也希望这可以通过 VBA 实现。
我在模块中有一些现有代码，用于根据 A 列中的值将工作表选项卡中的数据拆分到新工作表中（见下文）。这看起来效果很好。
但是，我们还需要（1）复制工作表保护/锁定单元格并（2）复制格式（即标题颜色），以便在拆分新工作表时将其拉到新工作表中。否则，拆分功能很有帮助，但我们将手动为 50 多个工作表添加工作表保护和着色标题。
是否可以调整下面的代码以合并上面的第 1 点和第 2 点，如果可以，如何调整？
提前非常感谢。
亲切的问候
阿克斯
这是现有的代码，但我不确定如何添加上面的第 1 点和第 2 点 - 如果可能的话？
Sub SplitSheetIntoMultipleWorkbooksBasedOnColumn()
Dim objWorksheet As Excel.Worksheet
Dim nLastRow, nRow, nNextRow As Integer
Dim strColumnValue As String
Dim objDictionary As Object
Dim varColumnValues As Variant
Dim varColumnValue As Variant
Dim objExcelWorkbook As Excel.Workbook
Dim objSheet As Excel.Worksheet
Set objWorksheet = ActiveSheet
nLastRow = objWorksheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row
Set objDictionary = CreateObject("Scripting.Dictionary")
For nRow = 2 To nLastRow
strColumnValue = objWorksheet.Range("A" & nRow).Value
If objDictionary.Exists(strColumnValue) = False Then
objDictionary.Add strColumnValue, 1
End If
Next
varColumnValues = objDictionary.Keys
For i = LBound(varColumnValues) To UBound(varColumnValues)
varColumnValue = varColumnValues(i)
Set objExcelWorkbook = Excel.Application.Workbooks.Add
Set objSheet = objExcelWorkbook.Sheets(1)
objSheet.Name = objWorksheet.Name
objWorksheet.Rows(1).EntireRow.Copy
objSheet.Activate
objSheet.Range("A1").Select
objSheet.Paste
For nRow = 2 To nLastRow
If CStr(objWorksheet.Range("A" & nRow).Value) = CStr(varColumnValue) Then
objWorksheet.Rows(nRow).EntireRow.Copy
nNextRow = objSheet.Range("A" & objWorksheet.Rows.Count).End(xlUp).Row + 1
objSheet.Range("A" & nNextRow).Select
objSheet.Paste
objSheet.Columns("A:F").AutoFit
End If
Next
Next
End Sub
IS_IN_TEST_MODEFalseSub SplitSheetIntoMultipleWorkbooksBasedOnColumn()
' Use something shorter and more user-friendly like 'ExportByName'.
' Define constants.
Const CRITERIA_COLUMN As String = "A"
Const DST_SUBFOLDER_NAME As String = "Items"
' The following two have to be 'in sync'!
Const DST_FILE_EXTENSION As String = ".xlsx"
Dim DST_FILE_FORMAT As XlFileFormat: DST_FILE_FORMAT = xlOpenXMLWorkbook
Const IS_IN_TEST_MODE As Boolean = True ' Careful! There is no Undo!
' Reference the source objects.
Dim swb As Workbook: Set swb = ThisWorkbook ' workbook containing this code
' If it's not, use 'ActiveWorkbook' instead.
If Len(swb.Path) = 0 Then
MsgBox "The workbook """ & swb.Name & """ was never saved!", _
vbExclamation
Exit Sub
End If
Dim sws As Worksheet: Set sws = swb.ActiveSheet ' improve!
Dim sName As String: sName = sws.Name
Dim srg As Range: Set srg = sws.Range("A1").CurrentRegion
Dim sRowsCount As Long: sRowsCount = srg.Rows.Count
If sRowsCount < 2 Then Exit Sub ' no data
Dim scrg As Range:
On Error Resume Next
Set scrg = Intersect(srg, sws.Columns(CRITERIA_COLUMN))
On Error GoTo 0
If scrg Is Nothing Then
MsgBox "The source range is ""'" & sName & "'!" & srg.Address(0, 0) _
& """. The criteria column """ & CRITERIA_COLUMN _
& """ is out of bounds!", vbExclamation
Exit Sub
End If
Dim ColumnsCount As Long: ColumnsCount = srg.Columns.Count
' Return the source data in arrays.
' If there are formulas that need to be preserved,
' use '.Formula' (or 'Formula2') instead of '.Value'!
Dim sData() As Variant: sData = srg.Value
' Here you need values!
Dim scData() As Variant: scData = scrg.Value
' Return the distinct values from the criteria array in the keys
' of a dictionary. Each corresponding item will hold a collection
' of the source rows.
' Also, calculate the maximum number of rows per value.
Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
dict.CompareMode = vbTextCompare
Dim sKey As Variant, sRow As Long, dRowsCount As Long
For sRow = 2 To sRowsCount
sKey = scData(sRow, 1)
If Not IsError(sKey) Then
sKey = CStr(sKey)
If Len(sKey) > 0 Then
If Not dict.Exists(sKey) Then
dict.Add sKey, New Collection
End If
dict(sKey).Add sRow
If dict(sKey).Count > dRowsCount Then
dRowsCount = dict(sKey).Count
End If
End If
End If
Next sRow
If dict.Count = 0 Then
MsgBox "There are only errors or blanks in the criteria range ""'" _
& sName & "'!" & scrg.Address(0, 0) & """!", vbExclamation
Exit Sub
End If
' Create a copy of the source worksheet in a new single-sheet workbook
' and clear the 'excessive' rows i.e. keep as many data rows
' as the maximum number of rows per value.
' This helper workbook with fewer rows will be repeatedly copied
' so fewer rows will have to be cleared.
Application.ScreenUpdating = False
sws.Copy
Dim cwb As Workbook: Set cwb = Workbooks(Workbooks.Count)
Dim cws As Worksheet: Set cws = cwb.Sheets(1)
cws.Range(srg.Address).Resize(sRowsCount - dRowsCount - 1) _
.Offset(dRowsCount + 1).Clear
' For each key in the dictionary, create a copy of the helper workbook
' (the copy becomes the destination workbook),
' copy the matching rows from the source array to the destination array,
' copy the values from the destination array to the destination range,
' clear excessive rows and save and close the destination workbook.
' Define the destination array.
Dim dData() As Variant: ReDim dData(1 To dRowsCount, 1 To ColumnsCount)
Dim dwb As Workbook, dws As Worksheet, drg As Range
Dim RowItem As Variant, c As Long
Dim dRow As Long, dFolderPath As String, dFilePath As String
For Each sKey In dict.Keys ' distinct criteria
' Return the matching rows at the top of the destination array.
dRow = 0
For Each RowItem In dict(sKey) ' source row numbers in collection
sRow = RowItem
dRow = dRow + 1
For c = 1 To ColumnsCount
dData(dRow, c) = sData(sRow, c)
Next c
Next RowItem
' Create a copy of the helper workbook,...
cws.Copy
' ... and reference this copy, the destination workbook.
Set dwb = Workbooks(Workbooks.Count)
Set dws = dwb.Sheets(1)
'dws.Name = sName
' Return the values from the destination array in the destination range.
Set drg = dws.Cells(1).Offset(1).Resize(dRow, ColumnsCount)
drg.Value = dData
' Clear below.
If dRow < dRowsCount Then
drg.Resize(dRowsCount - dRow + 1).Offset(dRow).Clear
End If
' Build the destination file path.
dFolderPath = swb.Path & Application.PathSeparator _
& IIf(Len(DST_SUBFOLDER_NAME) = 0, "", DST_SUBFOLDER_NAME _
& Application.PathSeparator)
If Len(Dir(dFolderPath, vbDirectory)) = 0 Then MkDir dFolderPath
dFilePath = dFolderPath & sKey & DST_FILE_EXTENSION
' Save and close the destination workbook.
If IS_IN_TEST_MODE Then
Dim dCount As Long: dCount = dCount + 1
dwb.Saved = True
MsgBox "File " & dCount & " would have been saved as """ _
& dFilePath & """!", vbExclamation
If dCount = 2 Then
MsgBox "Adjust the constants to get the desired paths." _
& vbLf & "Once they're satisfactory, set the " _
& """IS_IN_TEST_MODE"" constant to `False`!", _
vbCritical
Exit For
End If
Else
' To overwrite without confirmation, ...
' prevent dialog if different format,... and whatnot.
Application.DisplayAlerts = False
dwb.SaveAs dFilePath, DST_FILE_FORMAT
Application.DisplayAlerts = True
dwb.Close SaveChanges:=False ' just got saved
End If
Next sKey
' Close the helper workbook.
cwb.Close SaveChanges:=False
Application.ScreenUpdating = True
' Inform.
MsgBox "Workbooks created.", vbInformation
End Sub