使用 VBA 从 Excel 生成动态 CSV

Question

我们有一个要求，我们的用户可以隐藏/取消隐藏和移动 Excel 列。 一旦用户单击生成 CSV 按钮，我们希望列按特定顺序排列。 例如， Col1、Col2、Col3 是 Excel 第一行 A、B、C 列中的列标题。 用户将列 Col2 移到末尾并隐藏了 Col2： A、B、C 列现在有标题：Col1、Col3、Col2（隐藏）

我们的 CSV 文件应生成为：Col1、Col2、Col3。 使用下面的代码，我们看不到 Col2，即使我们设法取消隐藏，我们怎么知道用户最后移动了 Col2？

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

如果标题名称是固定的（并且只有位置不同），那么您将遍历标题以查找所需的标题，并记下它们的位置：然后使用该信息将单元格的值写入输出文件.

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

Answer 2

以给定的列顺序导出到 CSV

• 假定表格（第一行是标题）是连续的（没有空行或空列）并从单元格 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