Search code examples
excelvba

Formula is only showing up on the last workbook created from the split workbook macro?

enter image description herefollow up question to https://stackoverflow.com/a/77992051/22737370

I am having trouble with the code below. Only the last file created from it contains the formulas from the original file. I can't seem to figure out how to update the code so that all split files have the formulas from the main file. I have tried searching for different ways to write the code but haven't found anything that has helped. I tried removing the Paste Column Widths - thinking there were too many Paste commands but that did not work and also broke the locked cells command (meaning cells did not remain locked and hidden columns did not remain hidden)

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 = 5 ' 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("C" & 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 over column width
        objWorksheet.Range("A1").Resize(1, nColCnt).Copy
        objSheet.Range("A1").PasteSpecial Paste:=xlPasteFormulasAndNumberFormats, Operation:=xlNone, _
            SkipBlanks:=False, Transpose:=False
        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
          ' Remove filter
     Rows("5:5").AutoFilter
        objSheet.Cells.Locked = True
        objSheet.Range("Z:Z,AF:AF").Locked = False
        objSheet.Protect Password:="password", AllowFiltering:=True
        ' 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
Solution
    • If the filter data rows are non-contiguous (eg. row 3,4,6), objDic(varColValue).EntireRow.Copy objSheet.Cells(H_ROW + 1, 1) only copies its values.
    • Add For Each looping to copy each range area (contiguous rows)
    • Note: Col C (the key of Dict object) is used to determine the last data row on output sheet. Pls modify as needed.
        varColValues = objDic.Keys
    Dim areaRng As Range
    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:=xlPasteFormulasAndNumberFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        objSheet.Range("A1").PasteSpecial Paste:=xlPasteColumnWidths, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
        ' ** Copy rows to keep row height
        For Each areaRng In objDic(varColValue).Areas
            nLastRow = objSheet.Cells(objSheet.Rows.Count, "C").End(xlUp).Row
            areaRng.EntireRow.Copy objSheet.Cells(nLastRow + 1, 1)
        Next
        ' *** Update
        ' Remove filter
        objSheet.Rows("5:5").AutoFilter
        objSheet.Cells.Locked = True
        objSheet.Range("Z:Z,AF:AF").Locked = False
        objSheet.Protect Password:="password", AllowFiltering:=True
        ' Save the new workbook in a specific location
        savePath = "file path" ' Specify the save path here
        objExcelWorkbook.SaveAs savePath & varColValue & ".xlsx"
        objExcelWorkbook.Close
    Next