How can I Split this onto multiple Worksheets using a Macro

Maybe:

Sub kalvas()
Dim rcell As Range
Dim ws1 As Worksheet
Application.Calculation = xlCalculationManual
Application.ScreenUpdating = False
Set ws1 = Sheets("Sheet1")
ws1.Activate
For Each rcell In Range("C4:C" & Range("C" & Rows.count).End(3)(1).Row)
    If Len(rcell) > 2 Then
        Sheets.Add.Name = rcell.Value
        Sheets(rcell.Value).Columns(1).ColumnWidth = 5.14
        Sheets(rcell.Value).Columns(2).ColumnWidth = 11.29
        Sheets(rcell.Value).Columns(3).ColumnWidth = 7.29
        Sheets(rcell.Value).Columns(4).ColumnWidth = 27.14
        Sheets(rcell.Value).Columns(5).ColumnWidth = 8.57
        ActiveSheet.Rows("1:2").Value = ws1.Rows("2:3").Value
        ws1.Activate
        Range(Cells(rcell.Row, "A"), Cells(rcell.Row, "E")).Resize(26).Copy Sheets(rcell.Value).Range("A" & Rows.count).End(3)(2)
    End If
ws1.Activate
Next rcell
Application.Calculation = xlCalculationAutomatic
Application.ScreenUpdating = True
End Sub

Hi there,

Option Explicit
Sub Split()
Dim shtSrc As Worksheet
Dim xRow As Integer, xBreak As Integer: xBreak = 4

Application.ScreenUpdating = False
Set shtSrc = Sheets("Sheet1")

For xRow = 5 To shtSrc.Cells(Rows.Count, 1).End(xlUp).Row
  If shtSrc.Cells(xRow, 2) = "Company" Or shtSrc.Cells(xRow, 1) = "Totals" Then
    Worksheets.Add After:=ActiveSheet
    With ActiveSheet
      .Name = shtSrc.Cells(xBreak, 3)
      shtSrc.Range("A2:E3").Copy .Range("A2:E3")
      shtSrc.Cells(xBreak, 1).Resize(xRow - xBreak, 5).Copy .Range("A4")
      .Range("A:E").EntireColumn.AutoFit
    End With
  xBreak = xRow
  End If
Next xRow

Application.ScreenUpdating = True
End Sub

Hope it helps

double post

Hi Kalvas,

Must say I'm not a fan of individual tabs unless absoluately needed as you could just filter the data in Sheet1 and navigation around a 53 tab workbook is cumbersome.

That said, this will do the job:

Option Explicit

Sub Macro1()

    Const lngStartRow As Long = 4 'Consolidated data row start. Change to suit.

    Dim lngMyRow As Long, _
        lngEndRow As Long
    Dim wstMySheet As Worksheet
    Dim strMySheetName As String
    
    Application.ScreenUpdating = False
    
    lngEndRow = Sheets("Sheet1").Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = lngStartRow To lngEndRow Step 27
        'Create a tab only if there's value in lngMyRow of Col. C of 'Sheet1' and only if it doesn't already exist in the workbook
        If Len(Sheets("Sheet1").Range("C" & lngMyRow)) > 0 Then
            On Error Resume Next
                strMySheetName = CStr(Sheets("Sheet1").Range("C" & lngMyRow))
                Set wstMySheet = Sheets(strMySheetName)
                If Err.Number <> 0 Then
                    Worksheets.Add after:=Worksheets(Worksheets.Count)
                    Worksheets(Worksheets.Count).Name = strMySheetName
                    Sheets("Sheet1").Range("A2:E3").Copy Destination:=Sheets(strMySheetName).Range("A1")
                    Sheets("Sheet1").Range("A" & lngMyRow & ":E" & lngMyRow + 26).Copy Destination:=Sheets(strMySheetName).Range("A3")
                    Sheets(strMySheetName).Range("A:E").EntireColumn.AutoFit
                    Err.Clear
                End If
            On Error GoTo 0
        End If
    Next lngMyRow
    
    Application.ScreenUpdating = True
    
    MsgBox "Tabs have now been created.", vbInformation

End Sub

Regards,

Robert

how else would you suggest handling the information given that it will need to be printed?

Untested, but this should do the job:

Option Explicit

Sub Macro1()

    Const lngStartRow As Long = 4 'Consolidated data row start. Change to suit.

    Dim lngMyRow As Long, _
        lngEndRow As Long
    
    Application.ScreenUpdating = False
    
    lngEndRow = Sheets("Sheet1").Range("A:E").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    
    For lngMyRow = lngStartRow To lngEndRow Step 27
        With Sheets("Sheet1")
            .PageSetup.PrintArea = "$A$" & lngMyRow & ":$E$" & lngMyRow + 26
            .PrintOut
        End With
    Next lngMyRow
    
    Application.ScreenUpdating = True
    
    MsgBox "Accounts have now been printed.", vbInformation

End Sub

Robert