Copying Dynamic Range Into New Workbooks, Adding Header, And Saving New Workbooks To Local Directory Before Closing

Question

I have a master workbook with one sheet that I need to be broken into many workbooks that each have a single worksheet.

These newly created workbooks will be created wh

Answer 1

What think about this code.

Sub Splitter()
    Dim Master As Workbook
    Dim n As Integer
    Dim strFile As String

    Set Master = Workbooks("Master").Worksheets("Master") 'This declares the target worksheet.

    last = 1
    For i = 1 To 2000 'This defines the amount of rows
        If Range("B" & i) <> Range("B" & i + 1) Then
            strFile = ThisWorkbook.Path & "\" & Range("b" & i) & ".csv"
            TransToCSV strFile, Range("A" & last & ":F" & i)
            last = i + 1

        End If
    Next i
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, strHeader As String
    strHeader = "Header1,Header2,Header3,Header4,Header5,Header6" & vbCrLf
    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 = strHeader & Join(vTxt, vbCrLf)
    With objStream
        '.Charset = "utf-8"
        .Open
        .WriteText strTxt
        .SaveToFile myfile, 2
        .Close
    End With
    Set objStream = Nothing

End Sub