Split data into mukltiple sheets with condition

Question

I would like to split the data into multiple workbooks if it’s more than 250 rows and save each split files in the folder. I have created the macro for this but 250 items should be zero.

I have to post journals but data should not be more than 250 rows in excel and all items should be net zero.split workbook should be amount net zero. Hence minimum 244 to 250 maximum with zero.

Our challenges here is some times will get first Row Credit and second Row Debit but 3rd and 4th rows we get Credit and Credit and 5th and 6th Rows Debit and Debit entries.if we split data 250 rows might be chances that 249 and 250 rows Debit and Debit and next two rows 251 and 252 rows Credit and Credit which means two these rows split next work book.

Please assist me with macro file that how can we create Macro from 244 to 250 rows.

For example:

Count   Account D/C  Amount 
1   123456  C      1,200.00 
2   654321  D      1,200.00 
3   987654  C      4,000.00 
4   456789  D      4,000.00 
5   987987  C      3,700.00 
6   789789  C      3,700.00 
7   987987  D      3,700.00 
8   789789  D      3,700.00 
9   234234  C      8,700.00 
10  765765  D      8,700.00 
11  786953  C      7,890.00 
12  786953  C      7,890.00 
13  786953  C      7,890.00 
14  786953  C      7,890.00 
15  456345  D      7,890.00 
16  456345  D      7,890.00 
17  456345  D      7,890.00 
18  456345  D      7,890.00 
             Zero 

Macro I created.

Sub new1()
    Dim nRows As Long
    Dim i As Long
    Dim a As Long
    Dim b As String
    Dim r As Range
    Dim n As Long
    Dim today As Date

    Dim MainWorkBook As Worksheet
    Dim NewWorkBook As Workbook

    Set MainWorkBook = ThisWorkbook.ActiveSheet

    a = MainWorkBook.Cells(Rows.Count, 1).End(xlUp).Row

    b = 5
                                                                 'Current worksheet in workbook
    nRows = b
                                                                'Number of rows to split among worksheets
    n = 1

    For i = 2 To a Step nRows

    Set NewWorkBook = Workbooks.Add

    With NewWorkBook

    .SaveAs Filename:="H:\Macro\" & MainWorkBook.Name & "  " & Format(Date, "DD-MM-YYYY") & "    " & n & ".xlsm", FileFormat:= _
        xlOpenXMLWorkbookMacroEnabled, CreateBackup:=False



    Set r = Union(MainWorkBook.Rows(1), MainWorkBook.Rows(i).Resize(nRows))


    r.Copy Range("A1")

    n = n + 1


    End With

    NewWorkBook.Close SaveChanges:=True

    Next


End Sub

Answer 1

One approach is to read through the rows, keeping tracking of the cumulative value of the debits and credits, until the minimum number of rows is reached (e.g. 244 rows). Then as soon as the cumulative total of debits and credits is zero, close off the new workbook and start to write records into a new one. One code example is:

Option Explicit


Public Sub CreateExtract()

    Const cFileLocation = "H:\MACROS\"

    Const cMinRecords = 244

    Dim vMainWorkbook As Workbook
    Dim vMainSheet As Worksheet
    Dim vMainSheetLoop  As Long
    Dim vNewWorkbook As Workbook
    Dim vNewWorksheet As Worksheet
    Dim vNewSheetLoop As Long
    Dim vNewWorkbooks As Long
    Dim vDebitCredit As String
    Dim vAmount As Double
    Dim vAmountTotal As Double

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False

    Set vMainWorkbook = ThisWorkbook
    Set vMainSheet = ActiveSheet

    Set vNewWorkbook = Application.Workbooks.Add
    Set vNewWorksheet = vNewWorkbook.Sheets(1)

    ' Read through the data until an empty cell is found
    vMainSheetLoop = 2
    vNewSheetLoop = 0
    vAmountTotal = 0
    vNewWorkbooks = 1
    Do While vMainSheet.Cells(vMainSheetLoop, 1) <> ""

        ' Copy data into the new sheet and increment counter tracking records in the new sheet
        vNewSheetLoop = vNewSheetLoop + 1
        vMainSheet.Cells(vMainSheetLoop, 1).Resize(, 4).Copy vNewWorksheet.Cells(vNewSheetLoop, 1).Resize(, 4)

        ' Update the cumulative total taking into account debits and credits
        vDebitCredit = vMainSheet.Cells(vMainSheetLoop, 3)
        vAmount = vMainSheet.Cells(vMainSheetLoop, 4)
        vAmountTotal = vAmountTotal + (IIf(vDebitCredit = "D", -1, 1) * vAmount)

        ' If the minimum record count has been reached, and cumulative total is zero then save this workbook and start another ...
        If vNewSheetLoop >= cMinRecords And vAmountTotal = 0 Then
            vNewWorkbook.SaveAs cFileLocation & vMainWorkbook.Name & Format$(Date, "yyyy-mm-dd") & "-" & Format$(vNewWorkbooks, "000") & ".xlsx"
            vNewWorkbook.Close
            vNewWorkbooks = vNewWorkbooks + 1
            Set vNewWorkbook = Application.Workbooks.Add
            Set vNewWorksheet = vNewWorkbook.Sheets(1)
            vNewSheetLoop = 0
        End If

        vMainSheetLoop = vMainSheetLoop + 1
    Loop

    ' Close the last workbook (if it has data!)
    If vNewSheetLoop > 0 Then
        vNewWorkbook.SaveAs cFileLocation & vMainWorkbook.Name & Format$(Date, "yyyy-mm-dd") & "-" & Format$(vNewWorkbooks, "000") & ".xlsx"
    End If
    vNewWorkbook.Close

    Application.ScreenUpdating = True
    Application.DisplayAlerts = True

End Sub