使用VBA从Excel生成动态CSV

Question

我们要求用户可以隐藏/取消隐藏Excel列并在其中移动。用户单击generate 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

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

如果标头名称是固定的（只有位置不同），那么您将在标头上循环查找您想要的标头，并注意它们的位置：然后使用这些信息将单元格的值写入输出文件。

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