For Every 1500 Rows Copy To New Sheet & Save

BlakeSkate

Active Member
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

Active Member
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
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

Active Member
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
I'm glad to help you. Thanks for the feedback.
 

MoshiM

Active Member
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
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

Active Member
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
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
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
 

Some videos you may like

This Week's Hot Topics

Top