Generate Dynamic CSV from Excel using VBA

Question

We have a requirement where our Users can hide/Unhide and move around Excel Columns. Once the user clicks on generate CSV button, we want the columns to be in a particular sequence. For example, Col1, Col2, Col3 are the column headings in the Excel first row A,B,C Columns. User moved the column Col2 to the end and did hide Col2: A,B,C columns are now having headings: Col1, Col3, Col2(hidden)

Our CSV file should be generated as: Col1, Col2, Col3. Using below code, we are unable to see Col2 and even if we manage to unhide, how can we know that the user has moved the Col2 at the end?

Public Sub ExportWorksheetAndSaveAsCSV()

Dim csvFilePath As String
Dim fileNo As Integer
Dim fileName As String
Dim oneLine As String
Dim lastRow, lastCol As Long
Dim idxRow, idxCol As Long
Dim dt As String

dt = Format(CStr(Now), "_yyyymmdd_hhmmss")
' --- get this file name (without extension)
fileName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)
' --- create file name of CSV file (with full path)
csvFilePath = ThisWorkbook.Path & "\" & fileName & dt & ".csv"
' --- get last row and last column
lastRow = Cells(Rows.Count, 1).End(xlUp).Row
lastCol = Cells(1, Columns.Count).End(xlToLeft).Column
' --- open CSC file
fileNo = FreeFile
Open csvFilePath For Output As #fileNo
' --- row loop
For idxRow = 1 To lastRow
    If idxRow = 2 Then
        GoTo ContinueForLoop
    End If
    oneLine = ""
    ' --- column loop: concatenate oneLine
    For idxCol = 1 To lastCol
        If (idxCol = 1) Then
            oneLine = Cells(idxRow, idxCol).Value
        Else
            oneLine = oneLine & "," & Cells(idxRow, idxCol).Value
        End If
    Next

    ' --- write oneLine > CSV file
    Print #fileNo, oneLine  ' -- Print: no quotation (output oneLine as it is)
ContinueForLoop:
Next
' --- close file
Close #fileNo

End Sub

Answer 1

Export to CSV with Given Column Order

• It is assumed that the table (first row are headers) is contiguous (no empty rows or columns) and starts in cell A1.

Option Explicit

Sub exportToCSV()

    Const wsName As String = "Sheet1"
    Const TimePattern As String = "_yyyymmdd_hhmmss"
    
    Dim hCols As Variant: hCols = VBA.Array("Col1", "Col2", "Col3", "Col4")
    
    Dim wb As Workbook: Set wb = ThisWorkbook
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    ' If the data is not contiguous, you might need something different here.
    Dim rg As Range: Set rg = ws.Range("A1").CurrentRegion
    
    Dim Data As Variant: Data = rg.Value
    Dim hData As Variant: hData = rg.Rows(1).Value ' For 'Application.Match'
    
    Dim rCount As Long: rCount = UBound(Data, 1)
    
    Dim cHeader As Variant
    Dim dHeader As Variant
    Dim cIndex As Variant
    Dim Temp As Variant
    Dim r As Long, c As Long
    
    For c = 0 To UBound(hCols)
        cHeader = hCols(c)
        dHeader = Data(1, c + 1)
        If cHeader <> dHeader Then
            cIndex = Application.Match(cHeader, hData, 0)
            If IsNumeric(cIndex) Then
                For r = 1 To rCount
                    Temp = Data(r, c + 1)
                    Data(r, c + 1) = Data(r, cIndex)
                    Data(r, cIndex) = Temp
                Next r
            End If
        End If
    Next c
    
    Dim TimeStamp As String
    TimeStamp = Format(CStr(Now), TimePattern)
    Dim BaseName As String
    BaseName = Left(wb.Name, InStrRev(wb.Name, ".") - 1)
    Dim FilePath As String
    FilePath = wb.Path & "\" & BaseName & TimeStamp & ".csv"
    
    Application.ScreenUpdating = False
    
    With Workbooks.Add
        .Worksheets(1).Range("A1").Resize(rCount, UBound(Data, 2)).Value = Data
        .SaveAs Filename:=FilePath, FileFormat:=xlCSV
        ' 'Semicolon users' might need this instead:
        '.SaveAs Filename:=FilePath, FileFormat:=xlCSV, Local:=True
        .Close
    End With
    
    ' Test the result in the worksheet:
    'ws.Range("F1").Resize(rCount, UBound(Data, 2)).Value = Data

    Application.ScreenUpdating = True
    
End Sub

Answer 2

If the header names are fixed (and only the position varies) then you'd loop over the headers looking for the ones you want, and note their positions: then use that information to write the cells' values to the output file.

Public Sub ExportWorksheetAndSaveAsCSV()

    Dim csvFilePath As String
    Dim fileNo As Integer
    Dim fileName As String
    Dim oneLine As String
    Dim lastRow As Long
    Dim idxRow, idxCol As Long
    Dim dt As String, ws As Worksheet, hdr, arrCols, arrPos, i As Long, f As Range, sep
    
    
    Set ws = ActiveSheet 'or whatever
    lastRow = ws.Cells(ws.Rows.Count, 1).End(xlUp).Row
    
    'find all required columns
    arrCols = Array("Col1", "Col2", "Col3")
    ReDim arrPos(LBound(arrCols) To UBound(arrCols))
    For i = LBound(arrCols) To UBound(arrCols)
        'Note: lookin:=xlFormulas finds hidden cells but lookin:=xlValues does not...
        Set f = ws.Rows(1).Find(arrCols(i), lookat:=xlWhole, LookIn:=xlFormulas)
        If Not f Is Nothing Then
            arrPos(i) = f.Column
        Else
            MsgBox "Required column '" & arrCols(i) & "' not found!", _
                    vbCritical, "Missing column header"
            Exit Sub
        End If
    Next i
    'done finding columns
    
    fileName = Left(ThisWorkbook.Name, InStrRev(ThisWorkbook.Name, ".", -1, vbTextCompare) - 1)
    dt = Format(CStr(Now), "_yyyymmdd_hhmmss")
    csvFilePath = ThisWorkbook.Path & "\" & fileName & dt & ".csv"
    
    fileNo = FreeFile
    Open csvFilePath For Output As #fileNo
    
    For idxRow = 1 To lastRow
        If idxRow <> 2 Then
            oneLine = ""
            sep = ""
            'loop over the located column positions
            For idxCol = LBound(arrPos) To UBound(arrPos)
                oneLine = oneLine & sep & ws.Cells(idxRow, arrPos(idxCol)).Value
                sep = ","
            Next
            Print #fileNo, oneLine
        End If
    Next
    
    Close #fileNo ' --- close file

End Sub