Split file based on row and value

[arvsden]

Hi - new to the forum and hope that someone will be able to help. I have a file with more than 100k rows that I need to split into 1k row workbooks. So e.g. if a 3k row file would be split into 3 files, each new file has to start with "New Asset" on A2 but not go over 1000 row - (it's ok to go below 1000).

Here is the code that I currently use to split the file and a sample data that I am working on.

Sub Split_by_RowCount()

Dim M&, Ws As Worksheet, R&, N&
Dim inFile, outFile, importpath As Variant

inFile = Application.GetOpenFilename(Filefilter:="Excel Files(*.xlsx),*.xlsx", Title:="Data File")
            
    If inFile = False Then Exit Sub

outFile = ActiveWorkbook.Path & "\Output\"
   
   If Dir(outFile, 16) = "" Then MkDir outFile
         
    With Application
      Do
         M = .InputBox("Split row number?", "Split Excel File", 100, , , , , 1) - 1
         If M = -1 Then Exit Sub Else If M < 1 Then Beep
      Loop Until M > 0
        .DisplayAlerts = False
        .ScreenUpdating = False
        .SheetsInNewWorkbook = 1
         Set Ws = Workbooks.Add.Sheets(1)
    With Workbooks.Open(inFile, , , 2).Sheets(1).UsedRange.Rows
           .Item(1).Copy Ws.[A1]
        For R = 2 To .Count Step M
            N = N + 1
            Application.StatusBar = "       Workbook #" & N
           .Item(R).Resize(M).Copy Ws.[A2]
            Ws.Columns.AutoFit
            Ws.Parent.SaveAs outFile & Format(N, "000"), 51
            If N Mod 6 = 0 Then DoEvents
        Next
           .Parent.Parent.Close
    End With
        Ws.Parent.Close
        Set Ws = Nothing
       .DisplayAlerts = True
       .ScreenUpdating = True
       .StatusBar = False
    End With
        MsgBox N & " Workbooks Saved", 64, "Done"
End Sub
[CODE=vba]

[/CODE]

Sample:

A	B	C	D	E	F	G
New Asset	A	1000	01	02	DEAF5C42FA0B9205	TEST06SE1512
AddlTaxLot	T					TEST06SE1612
AddlTaxLot	T					TEST06SE1712
AddlTaxLot	T					TEST06SE1812
AddlTaxLot	T					TEST06SE1912
AddlTaxLot	T					TEST06SE2012
AddlTaxLot	T					TEST06SE2112
AddlTaxLot	T					TEST06SE2212
AddlTaxLot	T					TEST06SE2312
AddlTaxLot	T					TEST06SE2412
AddlTaxLot	T					TEST06SE2512
AddlTaxLot	T					TEST06SE2612
AddlTaxLot	T					TEST06SE2712
AddlTaxLot	T					TEST06SE2812
New Asset	A	1000	01	02	DEAF5C4300CE3206	TEST007SE0345
AddlTaxLot	T					TEST007SE0445
New Asset	A	1000	01	02	DEAF5C430497DC10	TEST155SE1544
AddlTaxLot	T					TEST155SE1644
AddlTaxLot	T					TEST155SE1744
AddlTaxLot	T					TEST155SE1844
AddlTaxLot	T					TEST155SE1944
AddlTaxLot	T					TEST155SE2044
AddlTaxLot	T					TEST155SE2144
AddlTaxLot	T					TEST155SE2244
AddlTaxLot	T					TEST155SE2344
AddlTaxLot	T					TEST155SE2444
AddlTaxLot	T					TEST155SE2544
AddlTaxLot	T					TEST155SE2644
AddlTaxLot	T					TEST155SE2744

 

[bobaol]

try this... '''assume you have two sheets, one named New_asset and one named Temp. Sheet New_asset is your original data.
'''assume columns AA to the right are blank, and can be used for temporary analysis, as all the analysis will be done in AA to the right
'''assumes your data starts in row2, as row1 is needed to use as a work space

Sub macro648902_run_copy_paste_to_new_book_()

    Application.DisplayAlerts = False
''  initial  Setup
    Application.Run " Macro648911"
    Application.Run " Macro648913"
    Application.Run " Macro648916"
    Application.Run " Macro648917"
    Application.Run " Macro648919"

'''loop to copy to new workbook
''macro will error out when done.  this is intentional, so you know it is done.
    For i = 1 To 6489
    Application.Run " Macro648920"
    Application.Run " Macro648921"
    Application.Run " Macro648922"
    Application.Run " Macro648923"
    Application.Run " Macro648924"
    Application.Run " Macro648925"
    Application.Run " Macro648927"
    Application.Run " Macro648936"
    Next
End Sub

Sub Macro648911()
'''assume you have two sheets, one named New_asset and one named Temp.  Sheet New_asset is your original data.
'''assume columns AA to the right are blank, and can be used for temporary analysis, as all the analysis will be done in AA to the right
'''assumes your data starts in row2, as row1 is needed to use as a work space
    Application.Goto Reference:="R1C1"
    Sheets("New_asset").Select
    Application.Goto Reference:="R1C1"
    Sheets("Temp").Select
    Application.Goto Reference:="R1C1"


'clear all, aa to az first
    Application.Goto Reference:="R1C1"
    Sheets("New_asset").Select
    Application.Goto Reference:="R1C1"
    Application.Goto Reference:="R1C27"
    ActiveCell.Columns("A:Z").EntireColumn.Select
    Selection.Clear


''find the number of rows in the sheet
    Application.Goto Reference:="R1C1"
    Sheets("New_asset").Select
    Application.Goto Reference:="R1C1"
    Application.Goto Reference:="R999999C1"
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Clear
    Selection.FormulaR1C1 = "=ROW()"
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    
'''cut the row number and paste it to E1, for use later
    Selection.Cut
    Application.Goto Reference:="R1C31"
    ActiveSheet.Paste
    Application.Goto Reference:="R1C30"
    Selection.FormulaR1C1 = "max rows"
    Application.Goto Reference:="R1C27"
End Sub


Sub Macro648913()
    
    Application.Goto Reference:="R1C1"
    Sheets("New_asset").Select
    Application.Goto Reference:="R1C1"
    Sheets("Temp").Select
    Application.Goto Reference:="R1C1"
    
'''formulas to determine where the "New Asset" splits.  headers and formulas here
    Sheets("New_asset").Select
    Application.Goto Reference:="R1C27"
    Selection.FormulaR1C1 = "''find new_asset"
    Application.Goto Reference:="R1C28"
    Selection.FormulaR1C1 = "''count of each new asset"
    Application.Goto Reference:="R2C27"
    Selection.FormulaR1C1 = "=IF(RC[-26]=""New Asset"",""New_Asset1"","""")"
    Application.Goto Reference:="R2C28"
    Selection.FormulaR1C1 = "=IF(RC[-1]=""New_Asset1"",1,R[-1]C+1)"
    ActiveCell.Offset(0, -1).Range("A1:B1").Select
    Selection.Copy
    
    Application.Goto Reference:="R2C27"
    Selection.Copy
    ActiveCell.Range("A1:B1").Select
    Selection.Copy

'''paste based on the maximum rows in cell AE1
''    ActiveCell.Range("A1:B3728").Select
    ActiveCell.Range("A1:B" & Range("ae1")).Select
    ActiveSheet.Paste
End Sub

Sub Macro648916()
'add in dummy New_Asset1 at the end of your data, as it will be needed to find the last row dynamically
    Sheets("New_asset").Select
    ActiveCell.Offset(0, -26).Range("A1:AA999998").Select
    ActiveCell.Activate
    Application.Goto Reference:="R999999C1"
    ActiveCell.Offset(-1, 0).Range("A1").Select
    Application.Goto Reference:="R999999C1"
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Copy
    ActiveCell.Offset(0, 26).Range("A1").Select
    Selection.FormulaR1C1 = "New_Asset1"
    Selection.Copy
    ActiveCell.Offset(0, 1).Range("A1:A9").Select
''clear anything below the end of the data.
    Selection.Clear
    Application.Goto Reference:="R1C1"
End Sub

Sub Macro648917()
'''in AC, use a formula to find the last row of each New_Asset section
    Sheets("New_asset").Select
    Application.Goto Reference:="R1C1"
    Sheets("New_asset").Select
    Application.Goto Reference:="R2C29"
    Selection.FormulaR1C1 = "=IF(R[1]C[-2]=""New_Asset1"",""Break_here"","""")"
    Selection.Copy
'''    ActiveCell.Range("A1:A3730").Select
    ActiveCell.Range("A1:A" & Range("ae1")).Select
    ActiveSheet.Paste
End Sub


Sub Macro648919()
'''formulas in AF to AK, find either New Asset, or if above row 1000, then indicated as New Asset1
    Sheets("New_asset").Select
    Application.Goto Reference:="R2C32"
    Application.CutCopyMode = False
    Selection.FormulaR1C1 = "=RC[-4]/1000"
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.FormulaR1C1 = "=SEARCH(""."",RC[-1])"
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.FormulaR1C1 = "=IF(ISERROR(R[-1]C[-1]),""New_Asset1"","""")"
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.FormulaR1C1 = "=IF(NOT(RC[-8]=""""),RC[-8],RC[-1])"
    ActiveCell.Offset(0, 1).Range("A1").Select
    Selection.FormulaR1C1 = "=IF(RC[-1]=""New_Asset1"",1,R[-1]C+1)"
''find last row of each section, as it will be needed to cut and paste to new sheet
    Application.Goto Reference:="R2C37"
    Selection.FormulaR1C1 = "=IF(R[1]C[-2]=""New_Asset1"",""Break_here"","""")"
    
    Application.Goto Reference:="R2C32"
    Selection.Copy
    ActiveCell.Range("A1:F1").Select
    Selection.Copy
''    ActiveCell.Range("A1:F121663").Select
    ActiveCell.Range("A1:F" & Range("ae1")).Select
    ActiveSheet.Paste
    Calculate
    
    '''copy all AA to right, paste as values
    Application.Goto Reference:="R1C27"
    ActiveCell.Columns("A:K").EntireColumn.Select
    Selection.Copy
    Application.CutCopyMode = False
    Calculate
    Selection.Copy
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
    Calculate

'clear all garbage in bottom, as it is no longer needed since all the formulas are now values
    Application.Goto Reference:="R999999C27"
    Selection.End(xlUp).Select
    Application.Goto Reference:="R999999C1"
    Selection.End(xlUp).Select
    ActiveCell.Offset(1, 0).Range("A1").Select
    Selection.Copy
    ActiveCell.Select
    Application.CutCopyMode = False
For i = 1 To 64
    Selection.EntireRow.Delete
Next

End Sub

Sub Macro648920()
'clear all in sheet Temp, so it can be used in a clean way
    Sheets("Temp").Select
    Application.Goto Reference:="R1C1"
    ActiveCell.Range("A1:AZ5").Select
    Selection.EntireColumn.Delete
    Application.Goto Reference:="R1C1"
End Sub

Sub Macro648921()
'find Break_here for last row in the section
    Sheets("New_asset").Select
    Application.Goto Reference:="R1C37"
    ActiveCell.Columns("A:A").EntireColumn.Select
    Selection.Find(What:="Break_here", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    ActiveCell.Offset(0, -1).Range("A1").Select
''copy it, paste it to AK1, to be used later
    Selection.Copy
    Application.Goto Reference:="R1C37"
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
''find Newe_Asset1 for the beginning row
    Application.Goto Reference:="R1C35"
    ActiveCell.Columns("A:A").EntireColumn.Select
    Selection.Find(What:="New_Asset1", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    ActiveCell.Offset(0, -1).Range("A1").Select
    Application.CutCopyMode = False
    Selection.Copy
''go to column A, then copy A to AK
    ActiveCell.Offset(0, -33).Range("A1").Select
    Selection.Copy
'''    ActiveCell.Range("A1:AK2").Select
    ActiveCell.Range("A1:AK" & Range("ak1")).Select
    Selection.Copy
    Sheets("Temp").Select
    Application.Goto Reference:="R3C1"
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
End Sub

Sub Macro648922()
'determine if cell AA3 has the word new asset.  if yes, then delete row 2.  if no, then keep row2 with the header New Asset
    Sheets("Temp").Select
    Application.Goto Reference:="R2C1"
    Application.CutCopyMode = False
    Selection.FormulaR1C1 = "New Asset"
    Application.Goto Reference:="R2C27"
    Selection.FormulaR1C1 = "=IF(RC[-26]=R[1]C[-26],""Delete_row"",""keep_row"")"
    Selection.Copy
End Sub

Sub Macro648923()
'''find Delete_row, if it exist, then delete row
    On Error GoTo Err_Handler
For i = 1 To 1
    Sheets("Temp").Select
    Application.Goto Reference:="R1C27"
    ActiveCell.Columns("A:A").EntireColumn.Select
    Selection.Find(What:="Delete_row", After:=ActiveCell, LookIn:=xlValues, LookAt:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False).Activate
    ActiveCell.Offset(0, -1).Range("A1").Select
    Selection.EntireRow.Delete
Next
Go_To_A1:
    Application.Calculation = xlAutomatic
Err_Handler:
    Application.Calculation = xlAutomatic
End Sub


Sub Macro648924()
'''delete AA to right
    Sheets("Temp").Select
    Application.Goto Reference:="R1C27"
    ActiveCell.Columns("A:Z").EntireColumn.Select
    Selection.Delete Shift:=xlToLeft
    Application.Goto Reference:="R1C1"
End Sub

Sub Macro648925()
'''give it Date Time in cell  A1, it will be save as the value in A1.
''you can change the name to whatever you want in A1, and it will save it as that
    Sheets("Temp").Select
    Application.Goto Reference:="R1C1"
    Selection.FormulaR1C1 = "=TEXT(NOW(),""yyyy_mm_dd__hh_mm_ss"")"
End Sub

Sub Macro648927()
'clear the copied date, so it makes way for the next section
    Sheets("New_asset").Select
    Selection.Copy
    ActiveCell.Offset(0, 26).Range("A1").Select
    ActiveSheet.Paste
    Selection.Clear
    Application.Goto Reference:="R1C37"
    Selection.Clear
End Sub

Sub Macro648936()
'copy A to Z to a new workbook.  save it as the value in cell A1, close it.
    Sheets("Temp").Select
    Application.Goto Reference:="R1C1"
    ActiveCell.Columns("A:Z").EntireColumn.Select
    Selection.Copy
    Workbooks.Add
    Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Selection.PasteSpecial Paste:=xlPasteFormats, Operation:=xlNone, SkipBlanks:=False, Transpose:=False
    Application.CutCopyMode = False
''' this save to the folder C:\Temp2\  you can save change it below to save to any folder, like G:\my6489date\
'''    ActiveWorkbook.SaveAs Filename:="C:\temp2\save as cell A1.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.SaveAs Filename:="C:\temp2\" & Range("a1") & ".xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    Application.Goto Reference:="R1C1"
    Selection.Clear
    ActiveWorkbook.Save
    ActiveWindow.Close
End Sub