Page 1 of 3 123 LastLast
Results 1 to 10 of 26

Thread: For Every 1500 Rows Copy To New Sheet & Save

  1. #1
    Board Regular BlakeSkate's Avatar
    Join Date
    Jan 2015
    Location
    Pernsylvoonia
    Posts
    461
    Post Thanks / Like
    Mentioned
    5 Post(s)
    Tagged
    0 Thread(s)

    Question For Every 1500 Rows Copy To New Sheet & Save

    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
    -------------------------------------------------------------------------------
    I may not give the best VBA codes, but they sure are VBA codes.
    Help me help you by posting a snapshot of your data & your expected result
    Please use [ code][ /code] tags when posting VBA as well as proper indentation

  2. #2
    Board Regular BlakeSkate's Avatar
    Join Date
    Jan 2015
    Location
    Pernsylvoonia
    Posts
    461
    Post Thanks / Like
    Mentioned
    5 Post(s)
    Tagged
    0 Thread(s)

    Default Re: For Every 1500 Rows Copy To New Sheet & Save

    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
    -------------------------------------------------------------------------------
    I may not give the best VBA codes, but they sure are VBA codes.
    Help me help you by posting a snapshot of your data & your expected result
    Please use [ code][ /code] tags when posting VBA as well as proper indentation

  3. #3
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    6,239
    Post Thanks / Like
    Mentioned
    71 Post(s)
    Tagged
    14 Thread(s)

    Default Re: For Every 1500 Rows Copy To New Sheet & Save

    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 = 1500
      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 & " " & i & ".csv", FileFormat:=xlCSV
        wb.Close False
      Next
      MsgBox "End"
    End Sub
    note: I added the variable i to the name to identify each file.
    Regards Dante Amor

  4. #4
    Board Regular BlakeSkate's Avatar
    Join Date
    Jan 2015
    Location
    Pernsylvoonia
    Posts
    461
    Post Thanks / Like
    Mentioned
    5 Post(s)
    Tagged
    0 Thread(s)

    Default Re: For Every 1500 Rows Copy To New Sheet & Save

    Quote Originally Posted by DanteAmor View Post
    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.
    -------------------------------------------------------------------------------
    I may not give the best VBA codes, but they sure are VBA codes.
    Help me help you by posting a snapshot of your data & your expected result
    Please use [ code][ /code] tags when posting VBA as well as proper indentation

  5. #5
    Board Regular DanteAmor's Avatar
    Join Date
    Dec 2018
    Location
    México
    Posts
    6,239
    Post Thanks / Like
    Mentioned
    71 Post(s)
    Tagged
    14 Thread(s)

    Default Re: For Every 1500 Rows Copy To New Sheet & Save

    I'm glad to help you. Thanks for the feedback.
    Regards Dante Amor

  6. #6
    Board Regular
    Join Date
    Jan 2018
    Posts
    234
    Post Thanks / Like
    Mentioned
    3 Post(s)
    Tagged
    0 Thread(s)

    Default Re: For Every 1500 Rows Copy To New Sheet & Save

    Quote Originally Posted by BlakeSkate View Post
    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

  7. #7
    MrExcel MVP
    Join Date
    May 2009
    Posts
    16,482
    Post Thanks / Like
    Mentioned
    37 Post(s)
    Tagged
    8 Thread(s)

    Default Re: For Every 1500 Rows Copy To New Sheet & Save

    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
    Joe

    When I was a young man I knew everything. Now that I'm older, I realize I know very little, and what I do know, I tend to forget!

  8. #8
    Board Regular BlakeSkate's Avatar
    Join Date
    Jan 2015
    Location
    Pernsylvoonia
    Posts
    461
    Post Thanks / Like
    Mentioned
    5 Post(s)
    Tagged
    0 Thread(s)

    Default Re: For Every 1500 Rows Copy To New Sheet & Save

    Quote Originally Posted by MoshiM View Post
    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?
    -------------------------------------------------------------------------------
    I may not give the best VBA codes, but they sure are VBA codes.
    Help me help you by posting a snapshot of your data & your expected result
    Please use [ code][ /code] tags when posting VBA as well as proper indentation

  9. #9
    Board Regular MARK858's Avatar
    Join Date
    Nov 2010
    Location
    Southern England
    Posts
    11,105
    Post Thanks / Like
    Mentioned
    1 Post(s)
    Tagged
    2 Thread(s)

    Default Re: For Every 1500 Rows Copy To New Sheet & Save

    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.
    Test VBA on a copy of your data (remember you can't normally reverse the action)

    Please follow the forum Rules and Guidelines & please use Code tags around your code i.e. [CODE]your code[/CODE]

    To post a screenshot try one of these links
    MrExcel HTML Maker, RoryA addin (Win & Mac) or Borders-Copy-Paste

  10. #10
    Board Regular
    Join Date
    Jan 2018
    Posts
    234
    Post Thanks / Like
    Mentioned
    3 Post(s)
    Tagged
    0 Thread(s)

    Default Re: For Every 1500 Rows Copy To New Sheet & Save

    Quote Originally Posted by BlakeSkate View Post
    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

User Tag List

Tags for this Thread

Like this thread? Share it with others

Like this thread? Share it with others

Posting Permissions

  • You may not post new threads
  • You may not post replies
  • You may not post attachments
  • You may not edit your posts
  •