How to efficiently create csv-files for each column in a worksheet?-CodePudding

I have a worksheet with many columns (82 in my case) and I am looking to create a csv-file for each column. I manage to do it with the below code, thanks to the help of many questions/answers on this site. Running the code gives some action on the windows taskbar I have not seen before (the creation and closing of the files) but I have the feeling there is a more efficient and faster way. Any suggestions?

' Create a separate csv file for each column.
Sub ColumnsToCSV()
Dim i As Byte
Dim cols As Byte                                                        ' column count
Dim name As String                                                      ' 01, 02, .., 99
cols = ActiveSheet.UsedRange.SpecialCells(xlCellTypeLastCell).Column    ' count columns

For i = 1 To cols                                                       ' loop columns
   name = Format(i, "00")                                               ' 1 => 01, etc.
   Sheets.Add(After:=Sheets(Sheets.Count)).name = name                  ' add sheet
   Sheets("Data").Columns(i).Copy Destination:=Sheets(name).Columns(1)  ' copy data
   ThisWorkbook.Sheets(name).Copy                                       ' create copy
   ActiveWorkbook.SaveAs Filename:=name, FileFormat:=xlCSV              ' save to csv
   ActiveWorkbook.Close                                                 ' close csv
   Application.DisplayAlerts = False                                    ' disable alerts
   ActiveSheet.Delete                                                   ' delete sheet
   Application.DisplayAlerts = True                                     ' enable alerts
Next i
End Sub

CodePudding user response：

Try this out:

' Create a separate csv file for each column.
Sub ColumnsToCSV()
                                                          
    Dim name As String, pth As String, cols As Long, i As Long
    Dim rng As Range, data, ws As Worksheet, r As Long, v
    
    Set ws = ActiveSheet
    cols = ws.UsedRange.SpecialCells(xlCellTypeLastCell).Column
    pth = ThisWorkbook.Path & "\"      'or whereever you want to save....
    
    For i = 1 To cols
        data = AsArray(ws.Range(ws.Cells(1, i), ws.Cells(Rows.Count, i).End(xlUp)))
        For r = 1 To UBound(data, 1)
            v = data(r, 1)
            If InStr(v, ",") > 0 Then data(r, 1) = """" & v & """" 'quote commas
        Next r
        'write the output (note Tanspose() has a limit of approx 63k items)
        PutContent pth & Format(i, "00") & ".csv", _
                   Join(Application.Transpose(data), vbCrLf)
    Next i
End Sub

'write text to a file
Sub PutContent(f As String, content As String)
    CreateObject("scripting.filesystemobject"). _
                  opentextfile(f, 2, True).write content
End Sub
'return range value as array (handle case where range is a single cell)
Function AsArray(rng As Range)
    Dim rv()
    If rng.Cells.Count = 1 Then
        ReDim rv(1 To 1, 1 To 1)
        rv(1, 1) = rng.Value
        AsArray = rv          'edit: this was missing...
    Else
        AsArray = rng.Value
    End If
End Function