For Every 1500 Rows Copy To New Sheet & Save

BlakeSkate

Well-known Member
Joined
Jan 26, 2015
Messages
517
Office Version
2016
Platform
Windows
I'm struggling with the logic behind this statement
I assign an entire sheet to an array
then i want
for every 1500 rows
write those values to new sheets
include header/insert header
save as csv (comma delimited) and close sheet
next 1500 rows

This is to happen until there are no rows left and the last sheet will be under 1500

My attempt:
Code:
Dim ary1 as Variant
Dim ws as WorkSheet
Dim i as Long
Dim x as Long

'establish sheet, array, and last column of activesheet
Set ws = ActiveSheet
  ary1 = ws.Range("A1").CurrentRegion.Value2
    lastCol = openWB.Sheets(1).Range("A1").SpecialCells(xlCellTypeLastCell).Column

'loop through array by rows
for i = 1500 to UBound(ary1)

'for every 1500 rows of the array what do?
Sheets.Add (After:= ws)
'ActiveSheet.Range("A1").Resize(???(ary1), lastCol).Value = ary1



Dim fold As String: fold = "C:\Users\user\Desktop\"
Dim fName  As String: fName = "newSHEET"

  With ActiveWorkbook
    .SaveAs fold & fName & Format(Date, "MM-DD-YYYY") & ".csv", FileFormat:=xlCSV
    .Close False
  End With
  
ActiveSheet.Delete

My brain is not comprehending how to loop through the array as 1500
any help would be appreciated
 

BlakeSkate

Well-known Member
Joined
Jan 26, 2015
Messages
517
Office Version
2016
Platform
Windows
maybe this?
Code:
    'ew math
    x = Floor((UBound(ary1) / 1500), 1500)
    
'for 1 to however many divisible 1500's
For i = 1 To x

'add sheet and paste values of array
Worksheets.Add After:=ws
ActiveSheet.Range("A1").Resize((x * 1500), lastCol).Value = ary1
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
7,969
Office Version
2007
Platform
Windows
Try this approch

Code:
Sub For_Every_1500()
  Dim sh As Worksheet, i As Long, wb As Workbook, fold As String, fname As String, n As Long
  '
  Application.ScreenUpdating = False
  Application.DisplayAlerts = False
  fold = "C:\Users\user\Desktop\"
  n = [COLOR=#0000ff]1500[/COLOR]
  fname = "newSHEET" & Format(Date, "MM-DD-YYYY")
  Set sh = ActiveSheet
  For i = 2 To sh.Range("A" & Rows.Count).End(xlUp).Row Step n
    Set wb = Workbooks.Add
    sh.Rows(1).Copy Range("A1")
    sh.Rows(i & ":" & i + n - 1).EntireRow.Copy Range("A2")
    wb.SaveAs Filename:=fold & fname & " " &[B][COLOR=#FF0000] i [/COLOR][/B]& ".csv", FileFormat:=xlCSV
    wb.Close False
  Next
  MsgBox "End"
End Sub
note: I added the variable i to the name to identify each file.
 

BlakeSkate

Well-known Member
Joined
Jan 26, 2015
Messages
517
Office Version
2016
Platform
Windows
Try this approch

note: I added the variable i to the name to identify each file.
thank you!
i didnt think of using "step" as i thought it was used to ignore rather than include.
but i see you fix it with copying the range using the n as a placeholder. math is not my strongest ability.
 

DanteAmor

Well-known Member
Joined
Dec 3, 2018
Messages
7,969
Office Version
2007
Platform
Windows
I'm glad to help you. Thanks for the feedback.
 

MoshiM

Active Member
Joined
Jan 31, 2018
Messages
278
I'm struggling with the logic behind this statement
I assign an entire sheet to an array
then i want
for every 1500 rows
write those values to new sheets
include header/insert header
save as csv (comma delimited) and close sheet
next 1500 rows

This is to happen until there are no rows left and the last sheet will be under 1500

My attempt:

My brain is not comprehending how to loop through the array as 1500
any help would be appreciated

I'm not sure if I properly understood what you want, but this is what I came up with:

Code:
Dim ary1 As Variant, ary2 As Variant, ws As Worksheet, I As Long, X As Long, Y As Long, G As Long, T As Long, _
NS As Worksheet, OpenWB As Workbook, M As Long


Dim fold As String: fold = "C:\Users\user\Desktop\"


Dim fName  As String: fName = "newSHEET"


'establish sheet, array, and last column of activesheet
Set OpenWB = ThisWorkbook


Set ws = ActiveSheet


     ary1 = ws.Range("A1").CurrentRegion.Value2


'loop through array by rows


G = UBound(ary1, 1) / 1500 'maximum number of arrays [result will be an integer]


I = 2 'skip headers when populating arrays


For X = 1 To G


    If X <> G Then 'if not in the last block of rows
    
        ReDim ary2(1 To 1500, 1 To UBound(ary1, 2))
        M = I + 1499
        
    Else
    
        ReDim ary2(1 To UBound(ary1, 1) Mod 1500, 1 To UBound(ary1, 2))
        M = I + (UBound(ary1, 1) Mod 1500) - 1 ' last block of rows
        
    End If


    For I = I To M 'populate rows of array
        
        For Y = LBound(ary1, 2) To UBound(ary1, 2) 'populate columns
        
            ary2(I Mod 1500, Y) = ary1(I, Y)
            
        Next Y
        
    Next I
    
    Set NS = Workbooks.Add.Worksheets(1) 'creates a new workbook with a reference to sheet index 1
    
    With NS
    
        .Range("A1").Resize(1, UBound(ary1, 2)).Value2 = Application.Index(ary1, 1, 0) 'apply headers
        
        .Range("A2").Resize(UBound(ary2, 1), UBound(ary2, 2)).Value2 = ary2 'place data on worksheet
        
        .Parent.SaveAs fold & fName & "_" & Format(Date, "MM-DD-YYYY") & "_" & X & ".csv", FileFormat:=xlCSV 'save worksheet to a CSV
        
        .Parent.Close
    
    End With
    
Next X


'ws.Delete   'deletes the data source sheet if uncommented
 

JoeMo

MrExcel MVP
Joined
May 26, 2009
Messages
16,645
You could also consider limiting the array to 1500 rows per loop, something like this:
Code:
Sub BlakeSkate()
Dim ary As Variant
Dim ws As Worksheet
Dim TotRws As Long, lastCol, Ct As Long
Dim NumRws As Long
'establish sheet, row count, and last column
Set ws = ActiveSheet
TotRws = ws.Range("A1").CurrentRegion.Rows.Count
lastCol = ws.Range("A1").CurrentRegion.Columns.Count
NumRws = 1500
Application.ScreenUpdating = False
Do
    ary = ws.Range(ws.Cells(Ct * NumRws + 1, "A"), ws.Cells(NumRws * (Ct + 1), lastCol)).Value2
    Sheets.Add after:=Sheets(Sheets.Count)
    'write ary to new sheet
    ActiveSheet.Range("A1", ActiveSheet.Cells(UBound(ary, 1), UBound(ary, 2))) = ary
    Ct = Ct + 1
    'code to do something with added sheet like save it as csv file
Loop While Ct * NumRws < TotRws
Application.ScreenUpdating = True
End Sub
 

BlakeSkate

Well-known Member
Joined
Jan 26, 2015
Messages
517
Office Version
2016
Platform
Windows
I'm not sure if I properly understood what you want, but this is what I came up with:

Code:
            ary2(I Mod 1500, Y) = ary1(I, Y)
i get "subscript out of range" on this line.
it stops on row 1500
I'm unaware of what mod does so i have absolutely no clue, but it might be off by 1?

Dante's code does what i want it to do, but does not use an array.
Using an array i would believe would be overall faster for my files which have 100,000+ rows of data?
 

MARK858

Well-known Member
Joined
Nov 12, 2010
Messages
11,345
Office Version
365, 2010
Platform
Windows, Mobile
Using an array i would believe would be overall faster for my files which have 100,000+ rows of data?

Why? you are writing a continuous range to the sheets the same number of times.
 

MoshiM

Active Member
Joined
Jan 31, 2018
Messages
278
i get "subscript out of range" on this line.
it stops on row 1500
I'm unaware of what mod does so i have absolutely no clue, but it might be off by 1?

Dante's code does what i want it to do, but does not use an array.
Using an array i would believe would be overall faster for my files which have 100,000+ rows of data?
Code:
Dim ary1 As Variant, ary2 As Variant, ws As Worksheet, I As Long, X As Long, Y As Long, G As Long, T As Long, _
NS As Worksheet, OpenWB As Workbook, M As Long


Dim fold As String: fold = "C:\Users\user\Desktop\"


Dim fName  As String: fName = "newSHEET"


'establish sheet, array, and last column of activesheet
Set OpenWB = ThisWorkbook


Set ws = ActiveSheet


     ary1 = ws.Range("A1").CurrentRegion.Value2


'loop through array by rows
If UBound(ary1, 1) Mod 1500 <> 0 Then I = 1


G = (UBound(ary1, 1) / 1500) + I 'maximum number of arrays [result will be an integer]


I = 2


For X = 1 To G


    If X <> G Then 'if not in the last block of rows
    
        ReDim ary2(1 To 1500, 1 To UBound(ary1, 2))
        M = I + 1499 'will evalulate to what ever the current value of I is + 1499 for a total of 1500 rows
        
    Else
    
        ReDim ary2(1 To UBound(ary1, 1) Mod 1500, 1 To UBound(ary1, 2))
        M = I + (UBound(ary1, 1) Mod 1500) - 1 ' last block of rows
        
    End If


    For I = I To M 'populate rows of array
        
        For Y = LBound(ary1, 2) To UBound(ary1, 2) 'populate columns
        
            ary2((I - 1 Mod 1500), Y) = ary1(I, Y)
            
        Next Y


    Next I
    
    Set NS = Workbooks.Add.Worksheets(1) 'creates a new workbook with a reference to sheet index 1
    
    With NS
    
        .Range("A1").Resize(1, UBound(ary1, 2)).Value2 = Application.Index(ary1, 1, 0) 'headers
        
        .Range("A2").Resize(UBound(ary2, 1), UBound(ary2, 2)).Value2 = ary2 'place data on worksheet
        
        .Parent.SaveAs fold & fName & "_" & Format(Date, "MM-DD-YYYY") & "_" & X & ".csv", FileFormat:=xlCSV 'save worksheet to a CSV
        
        .Parent.Close
    
    End With
    
Next X


'ws.Delete   'deletes the data source sheet if uncommented
 

Forum statistics

Threads
1,078,515
Messages
5,340,863
Members
399,396
Latest member
PBE

Some videos you may like

This Week's Hot Topics

  • Problem with Radio Button's format control
    I am creating an employee evaluation template (a sample is below) Column A is the category Column B, C D, E and F will be ratings (unacceptable...
  • Last Display on userform to a Listbox
    [CODE=vba] lstdisplay.ColumnCount = 15 lstdisplay.RowSource = "A1:O600000" [/CODE] So when i do this it Displays everything on the sheet i am...
  • Rename and move files to a new location
    Dear all, I have an excel file with the following information. The actual file name is at column A but i want to rename it using the following...
  • Help with True/False Formula
    Hello! Am stumped how to fix this formula, in which my result returns 'True', but it should return False. =IF(AG2=True...
  • Clear extra characters from a provided range of cells
    Dear All, I have following code which gives me desired output to remove extra characters from a provided range. But it takes too much time when...
  • Help with Current and highest streaks
    Hi there, I've just joined the forum and this is my first post. I've already spent quite a bit of time searching the net and this forum for a...
Top