Create/rename sheets and export them as CSV

Question

I have in the worksheet "AllData", a list of data that is updated every day.

I want to copy every 20 rows from this sheet (Alldata) to a new sheet, name it "1", "2", "3"...consecutively as needed, and then export every created sheet to a new workbook as CSV.

(Example: 'Alldata' sheet contains 103 rows, and the code must create six new sheets, named 1, 2, 3, 4, 5, and 6 containing respectively 20, 20, 20, 20, 20, and 3 rows copied from the Alldata sheet.

How can this be done?

start by recording a macro of new worksheet creation, renaming, then copying 20 rows, then exporting to csv. .... use the resulting macro code as a base to expand upon. — jsotola, Oct 01 '17 at 06:40
refer to [this](https://stackoverflow.com/questions/44771525/convert-xlsx-to-csv-using-vba-script/44772070#44772070) — Dy.Lee, Oct 01 '17 at 06:47

score 1 · Answer 1 · edited Oct 16 '17 at 21:02

This converts a range to a CSV file directly:

Sub SaveRangeToCsvFiles()

    Dim FileName As String
    Dim Ws As Worksheet, Wb As Workbook
    Dim rngDB As Range
    Dim r As Long, c As Long
    Dim pathOut As String
    Dim i As Long, n As Long

    pathOut = ThisWorkbook.Path & "\"

    Set Ws = ActiveSheet 'Sheets("AllData")
    With Ws
        r = .Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
        c = .Cells.Find("*", SearchOrder:=xlByColumns, SearchDirection:=xlPrevious).Column
        For i = 1 To r Step 20
            n = n + 1
            If i + 20 > r Then
                Set rngDB = Range("a" & i).Resize(r - i + 1, c)
            Else
                Set rngDB = Range("a" & i).Resize(20, c)
            End If
            TransToCSV pathOut & n & ".csv", rngDB
        Next i
    End With
    MsgBox ("Files Saved Successfully")
End Sub

Sub TransToCSV(myfile As String, rng As Range)

    Dim vDB, vR() As String, vTxt()
    Dim i As Long, n As Long, j As Integer
    Dim objStream
    Dim strTxt As String

    Set objStream = CreateObject("ADODB.Stream")
    vDB = rng

    For i = 1 To UBound(vDB, 1)
        n = n + 1
        ReDim vR(1 To UBound(vDB, 2))
        For j = 1 To UBound(vDB, 2)
            vR(j) = vDB(i, j)
        Next j
        ReDim Preserve vTxt(1 To n)
        vTxt(n) = Join(vR, ",")
    Next i

    strTxt = Join(vTxt, vbCrLf)

    With objStream
        '.Charset = "utf-8"
        .Open
        .WriteText strTxt
        .SaveToFile myfile, 2
        .Close
    End With
    Set objStream = Nothing
End Sub

score 1 · Answer 2 · edited Oct 16 '17 at 21:05

Use the below for creating a new sheet:

Private Sub CreateSheet()
    Dim ws As Worksheet
    Dim i As Integer
    For i = 1 To 6
        Set ws = ThisWorkbook.Sheets.Add(After:= _
                ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        ws.Name = CStr(i)
    Next i
End Sub 'CreateSheet

And below procedure for calling export function:

Sub ExportCsV
Dim i As Integer
For i = 1 to 20
    CsvExportRange rngRange:=ThisWorkbook.Worksheets(CStr(i)).Range("A1:A20"), _
      strFileName:=ThisWorkbook.path & "Result" & CStr(i) & ".csv", _
      strCharset:="UTF-8", strSeparator:=",", strRowEnd:=vbCrLf, NVC:=False
Next i
End Sub 'ExportCsV

And use below for export CSV, with string reformat addition function. (Note: in above module or call with appropriated module name, before.)

Sub CsvExportRange(rngRange As Object, strFileName As String, strCharset, strSeparator As String, strRowEnd As String, NVC As Boolean) 'NVC: _
    Null Value Control (If cell contain Null value, suppose reached end of range), d: delimiter

    Dim rngRow As Range
    Dim objStream As Object
    Dim i, lngFR, lngLR As Long 'lngFR: First Row, lngLR: Last Row

    lngFR = rngRange.SpecialCells(xlCellTypeVisible).Rows(1).row - rngRange.Rows(1).row + 1
    lngLR = rngRange.End(xlDown).row - rngRange.Rows(1).row + 1

    Set objStream = CreateObject("ADODB.Stream")
    objStream.Type = 2
    objStream.Charset = strCharset
    objStream.Open

    For i = lngFR To lngLR
        If Not (rngRange.Rows(i).EntireRow.Hidden) Then
            If IIf(NVC, (Cells(i + rngRange.Rows(1).row - 1, _
                rngRange.SpecialCells(xlCellTypeVisible).Columns(1).column).Value = vbNullString), False) Then Exit For
            objStream.WriteText CsvFormatRow(rngRange.Rows(i), strSeparator, strRowEnd)
        End If
    Next i

    objStream.SaveToFile strFileName, 2
    objStream.Close
End Sub 'CsvExportRange

Function CsvFormatRow(rngRow As Variant, strSeparator As String, strRowEnd As String) As String

    Dim arrCsvRow() As String

    ReDim arrCsvRow(rngRow.SpecialCells(xlCellTypeVisible).Cells.Count - 1)
    Dim rngCell As Range
    Dim lngIndex As Long

    lngIndex = 0

    For Each rngCell In rngRow.SpecialCells(xlCellTypeVisible).Cells
        arrCsvRow(lngIndex) = CsvFormatString(rngCell.Value, strSeparator)
        lngIndex = lngIndex + 1
    Next rngCell

    CsvFormatRow = Join(arrCsvRow, strSeparator) & strRowEnd
End Function 'CsvFormatRow

Function CsvFormatString(strRaw, strSeparator As String) As String

    Dim boolNeedsDelimiting As Boolean

    Dim strDelimiter, strDelimiterEscaped As String

    strDelimiter = """"
    strDelimiterEscaped = strDelimiter & strDelimiter

    boolNeedsDelimiting = InStr(1, strRaw, strDelimiter) > 0 _
        Or InStr(1, strRaw, chr(10)) > 0 _
        Or InStr(1, strRaw, strSeparator) > 0

    CsvFormatString = strRaw

    If boolNeedsDelimiting Then
        CsvFormatString = strDelimiter & _
            Replace(strRaw, strDelimiter, strDelimiterEscaped) & _
            strDelimiter
    End If
End Function 'CsvFormatString

References:

stackoverflow_Named Sheets

stackoverflow_CSV

Create/rename sheets and export them as CSV

2 Answers2

Linked