VBA Code to Split a column into new workbooks

[CarlosMD]

I have a workbook with one column of 30,000+ rows. I'd like to split that column up every 1,000 rows and put it into a new csv workbook with a header. I'd also like to name the new files in numeral order (ex: first 1000 rows go into a new workbook named "1", next 1000 rows go into a workbook named "2", etc)

Currently using a VBA code to split the column into new xlsx workbooks with no header. This code does not save the new workbooks that are created. I'll attach the code if it's easier to just modify it


VBA CODE:

Sub split()

    'Set dimensions
    Dim Table As Range, TableArray(), _
        CutValue As Integer, Cntr As Integer, _
        TempArray(), Width As Integer, _
        x As Integer, y As Integer, _
        Height As Long, Rep As Integer, _
        LoopReps As Long

    'Get data
    Set Table = Application.InputBox("Specify range to copy", _
        Default:=ActiveCell.CurrentRegion.Address, Type:=8)
    CutValue = InputBox("How many rows should the chunks be?", _
        Default:=1000)
    Width = 1
    Height = Table.Rows.Count

    'Write to array
    TableArray = Table
    ReDim TempArray(1 To CutValue, 1 To Width)
    Rep = Application.WorksheetFunction.RoundUp(Height / CutValue, 0)
    LoopReps = CLng(CutValue)

    'Loop through all new sheets
    For Cntr = 0 To Rep - 1
        If Height - Cntr * CLng(CutValue) < CLng(CutValue) Then _
            LoopReps = Height - Cntr * CLng(CutValue)

        For x = 1 To Width
            For y = 1 To LoopReps
                TempArray(y, x) = TableArray(y + Cntr * CLng(CutValue), x)
            Next y
        Next x

        Workbooks.Add
        Range("A1").Resize(LoopReps, Width) = TempArray
    Next Cntr

End Sub

 

[mohadin]

Hi
Try this code NOT TESTED

Sub test()
    Dim a As Variant
    Dim i As Long
    a = Cells(1, 1).CurrentRegion
    Sheets.Add.Name = "Temp"
    With ActiveSheet
        For i = 2 To UBound(a) Step 1000
            .Cells(1, 1) = a(1, 1)
            .Cells(2, 1).Resize(1000) = Application.Index(a, Evaluate("row(" & i & ":1000" & ")"), Array(1))
            .SaveAs ThisWorkbook.Path & i & ".csv", xlCSV
        Next
    End With
    Application.DisplayAlerts = False
    Sheets("Temp").Delete
    Application.DisplayAlerts = True
End Sub

 

[CarlosMD]

Hi
Try this code NOT TESTED

Sub test()
    Dim a As Variant
    Dim i As Long
    a = Cells(1, 1).CurrentRegion
    Sheets.Add.Name = "Temp"
    With ActiveSheet
        For i = 2 To UBound(a) Step 1000
            .Cells(1, 1) = a(1, 1)
            .Cells(2, 1).Resize(1000) = Application.Index(a, Evaluate("row(" & i & ":1000" & ")"), Array(1))
            .SaveAs ThisWorkbook.Path & i & ".csv", xlCSV
        Next
    End With
    Application.DisplayAlerts = False
    Sheets("Temp").Delete
    Application.DisplayAlerts = True
End Sub

Hi Thank you for the response! Unfortunately, this code is just taking the same 1000 rows and saving it into files. So, when I have a header and 31,000 rows it will create 31 files, 30 of which have the same header and 1000 rows (row 1000-1999 from the original list). The 1st file is different. The first 3 rows are the same as the rest and then the rest of the 1000 rows are filled with NAs. Not sure what is causing this problem

 

[mohadin]

Hi
will you try

Sub test()
    Dim a As Variant
    Dim i As Long
    a = Sheet1.Cells(1, 1).CurrentRegion
    Sheets.Add.Name = "Temp"
    With ActiveSheet
        For i = 2 To UBound(a) Step 999
            .Cells(1, 1) = a(1, 1)
            x = Application.Transpose(Evaluate("row(" & i & ":" & Evaluate(i & " + 999") & ")"))
            .Cells(2, 1).Resize(999) = Application.Transpose(Application.Index(a, x, 1))
            .SaveAs ThisWorkbook.Path & i & ".csv", xlCSV
        Next
    End With
    Application.DisplayAlerts = False
    Sheets("Temp").Delete
    Application.DisplayAlerts = True
End Sub