# Splitting Excel Worksheet



## Mthalaj (Dec 10, 2022)

Hello Everyone, 

I am facing a complicated case that I couldn't find any solution for it. 

I have an excel sheet containing an index of database contents, This sheet has 20 columns and thousands of rows. 

one of these columns is the file storage size, The columns are sorted ascending, and I want to split the sheet each time the sum of the storage reaches 9. 
In other words, I want to sum the storage sizes, and each time the storage reaches ~9  I want to move all the rows that are included in the calculation to another sheet.

The numbers stored in this column are Decimal Numbers. 

This is a sample of the sheet:






I know it sounds crazy, but I am sure I will find someone who can help me here


----------



## Mthalaj (Dec 18, 2022)

Your help is highly appreciated guys


----------



## John_w (Dec 18, 2022)

Try this macro, which looks at the active sheet.


```
Option Explicit

Public Sub Split_Sheet_By_Column_Sum()

    Dim dataSheet As Worksheet
    Dim headerRange As Range, copyRange As Range
    Dim newSheet As Worksheet
    Dim colJ As Variant, colJsum As Double
    Dim lastRow As Long, r As Long, startRow As Long
   
    Const colJmax As Double = 9#
    
    Application.ScreenUpdating = False
    
    Set dataSheet = ThisWorkbook.ActiveSheet
    
    With dataSheet
    
        Set headerRange = .Range("A1").Resize(, .UsedRange.Columns.Count)
        lastRow = .Cells(.Rows.Count, "J").End(xlUp).Row
        colJ = .Range("J1:J" & lastRow).Value
    
        r = 2
        While r <= lastRow
        
            startRow = r
            colJsum = 0
            While r <= lastRow And colJsum < colJmax
                colJsum = colJsum + colJ(r, 1)
                r = r + 1
            Wend
                
            Set newSheet = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
            headerRange.Copy newSheet.Range("A1")
            Set copyRange = .Cells(startRow, 1).Resize(r - startRow, .UsedRange.Columns.Count)
            copyRange.Copy newSheet.Range("A2")
            
        Wend
        
    End With
    
    Application.ScreenUpdating = True
    
    MsgBox "Done"

End Sub
```


----------

