Is there a way to keep formatting (rows and column size) and locked cells on a macro?

Question

Below is the code I am using. I would like to edit it so that it will maintain column and row size as well as maintaining locked cells on the split workbooks. Currently the codes splits the original file but doesn't maintain formatting which requires a lot of manual work to make the files shareable.

Option Explicit

Sub SplitSheetIntoMultipleWorkbooksBasedOnColumn()
    Dim objWorksheet As Worksheet
    Dim nLastRow As Long, nRow As Long``
    Dim nColCnt As Long, rowRng As Range
    Dim strColValue As String, savePath As String
    Dim objDic As Object, i As Long
    Dim varColValues As Variant
    Dim varColValue As Variant
    Dim objExcelWorkbook As Workbook
    Dim objSheet As Worksheet
    Const H_ROW = 8 ' header row#
    Set objWorksheet = ActiveSheet
    With objWorksheet
        nLastRow = .Range("A" & .Rows.Count).End(xlUp).Row
        nColCnt = .Cells(H_ROW, .Columns.Count).End(xlToLeft).Column
        Set objDic = CreateObject("Scripting.Dictionary")
        ' Loop through data
        For nRow = H_ROW + 1 To nLastRow
            strColValue = Trim(.Range("B" & nRow).Value)
            If Len(strColValue) > 0 Then
                ' Store data range in Dict
                Set rowRng = .Cells(nRow, 1).Resize(1, nColCnt)
                If objDic.Exists(strColValue) Then
                    Set objDic(strColValue) = Union(rowRng, objDic(strColValue))
                Else
                    Set objDic(strColValue) = rowRng
                End If
            End If
        Next
    End With
    varColValues = objDic.Keys
    For i = LBound(varColValues) To UBound(varColValues)
        varColValue = varColValues(i)
        Set objExcelWorkbook = Workbooks.Add
        Set objSheet = objExcelWorkbook.Sheets(1)
        objSheet.Name = objWorksheet.Name
        ' Copy header and above rows
        objWorksheet.Rows("1:" & H_ROW).Copy objSheet.Range("A1")
        ' Copy data rows
        objDic(varColValue).Copy objSheet.Cells(H_ROW + 1, 1)
        ' Save the new workbook in a specific location
        savePath = "file path" ' Specify the save path here
        objExcelWorkbook.SaveAs savePath & varColValue & ".xlsx"
        objExcelWorkbook.Close
    Next
End Sub

I have tried researching and haven't come up with anything that was helpful

Answer 1

Changes:

• Coping the entire rows keeps the row height
• Use xlPasteColumnWidths to keep the column width
• freeze panes is a setting of Window. You can't copy it over. If all files have same setting, you could add code to apply freeze panes before save the file.
• The status of locked is copied over base on my testing (M365).

    varColValues = objDic.Keys
    For i = LBound(varColValues) To UBound(varColValues)
        varColValue = varColValues(i)
        Set objExcelWorkbook = Workbooks.Add
        Set objSheet = objExcelWorkbook.Sheets(1)
        objSheet.Name = objWorksheet.Name
        ' Copy header and above rows
        objWorksheet.Rows("1:" & H_ROW).Copy objSheet.Range("A1")
        ' ** Copy over column width
        objWorksheet.Range("A1").Resize(1, nColCnt).Copy
        objSheet.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False        
        ' ** Copy rows to keep row height
        objDic(varColValue).EntireRow.Copy objSheet.Cells(H_ROW + 1, 1)
        ' Save the new workbook in a specific location
        savePath = "file path" ' Specify the save path here
        objExcelWorkbook.SaveAs savePath & varColValue & ".xlsx"
        objExcelWorkbook.Close
    Next

---

Update:

Question: all cells are locked except Col T, U, V

    varColValues = objDic.Keys
    For i = LBound(varColValues) To UBound(varColValues)
        varColValue = varColValues(i)
        Set objExcelWorkbook = Workbooks.Add
        Set objSheet = objExcelWorkbook.Sheets(1)
        objSheet.Name = objWorksheet.Name
        ' Copy header and above rows
        objWorksheet.Rows("1:" & H_ROW).Copy objSheet.Range("A1")
        ' ** Copy over column width
        objWorksheet.Range("A1").Resize(1, nColCnt).Copy
        objSheet.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False        
        ' ** Copy rows to keep row height
        objDic(varColValue).EntireRow.Copy objSheet.Cells(H_ROW + 1, 1)
        ' *** Update
        objSheet.Cells.Locked = True 
        objSheet.Range("T:T,U:U,V:V").Locked = False
        objSheet.Protect Password:="Enter your Password"
        ' Save the new workbook in a specific location
        savePath = "file path" ' Specify the save path here
        objExcelWorkbook.SaveAs savePath & varColValue & ".xlsx"
        objExcelWorkbook.Close
    Next