For Every 1500 Rows Copy To New Sheet & Save

DataBlake

Well-known Member
Joined
Jan 26, 2015
Messages
781
Office Version
  1. 2016
Platform
  1. 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
 

Excel Facts

Does the VLOOKUP table have to be sorted?
No! when you are using an exact match, the VLOOKUP table can be in any order. Best-selling items at the top is actually the best.
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
 
Upvote 0
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.
 
Upvote 0
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.
 
Upvote 0
I'm glad to help you. Thanks for the feedback.
 
Upvote 0
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
 
Upvote 0
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
 
Upvote 0
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?
 
Upvote 0
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.
 
Upvote 0
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
 
Upvote 0

Forum statistics

Threads
1,213,526
Messages
6,114,122
Members
448,550
Latest member
CAT RG

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top