如何在不打开文件的情况下将数组写入.csv文件？

已完成输入文件的字符串流读取、逗号与引号解析清理，将元素分配到数组并转置到工作表，但需求是不打开目标文件的前提下，把数组内容写入输出文件。

尝试过Print #1、Write #1、GetObject及重置打印区域等方法均失败，其中Print语句虽支持vbCRLf，但无法切换列，导致所有行内容都输出到同一列。

原代码：

Option Explicit

Sub Test()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    
    'A
        Dim h                   As Integer:           h = 0
        Dim i                   As Integer:           i = 0
        Dim j                   As Integer:           j = 0
        Dim k                   As Integer:           k = 0
        Dim wsf                 As WorksheetFunction: Set wsf = Application.WorksheetFunction
        Dim wb                  As Workbook:          Set wb = ThisWorkbook
        Dim ws                  As Worksheet:         Set ws = wb.Worksheets(1)
        Dim FileArray()         As Variant, _
            SplitDataAgain()    As Variant, _
            SplitData()         As String, _
            CopiedData          As String, _
            CleanStr            As String, _
            fPath1              As String, _
            fPath2              As String
            fPath2 = "[OUTPUT FILE]"
            fPath1 = "[INPUT FILE]"
        
        Dim Test                As Variant
            
    'B
        Open fPath1 For Binary Access Read As #1
        CopiedData = Space(LOF(1))
        Get #1, , CopiedData
        Close #1

    'C
        SplitData() = Split(CopiedData, vbCrLf)
        Do
            '1
            CleanStr = StrCleaning(i, SplitData())                  'Handle dollar values
            '2
            ReDim Preserve SplitDataAgain(i)                        'New row
            SplitDataAgain(i) = Split(SplitData(i), ",")            'Populate row
            k = UBound(SplitDataAgain(0))                           'Cols
            h = UBound(SplitDataAgain())                            'Rows
            i = i + 1
        Loop Until i > (UBound(SplitData()) - 1)
        ReDim FileArray(k, h)                                       'Proportions of file
        
        '3
        For i = 0 To h                                              'Cols
            For j = 0 To k                                          'Rows
                FileArray(j, i) = SplitDataAgain(i)(j)              'Invert and populate
            Next j
        Next i
        
    'D
        ws.Range(ws.Cells(1, 1), ws.Cells(h + 1, k + 1)) = wsf.Transpose(FileArray())
    
    'E
        Open fPath2 For Output As #1
            For i = 0 To h
                For j = 0 To k
                    Test = FileArray(j, i)
                    If j <> k Then
                        Print #1, Test,
                        Else:   Print #1, Test
                    End If
                Next j
            Next i
        Close #1
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic

End Sub

Private Function StrCleaning(i As Integer, SplitData() As String) As String

    Dim rx1                  As RegExp:           Set rx1 = New RegExp
    Dim rx2                  As RegExp:           Set rx2 = New RegExp
    Dim FindStr1             As String:           FindStr1 = "((?:^|,)\\""[^"\\",]*),"          'Commas for rx1
    Dim FindStr2             As String:           FindStr2 = "(?:[\\""\""]*)([.]*)(?:[\\""\""]*)"     'Quotations for rx2
    Dim ReplaceStr           As String:           ReplaceStr = "$1"                         'Grouping of rx1 and rx2
    Dim p                    As Integer
    With rx1
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = FindStr1                                                 'Pattern of number commas
    End With
    With rx2
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = FindStr2                                                 'Pattern of quotations
    End With
    
    For p = 1 To 3
        SplitData(i) = rx1.Replace(SplitData(i), ReplaceStr)                'Removing commas
    Next p
    SplitData(i) = rx2.Replace(SplitData(i), ReplaceStr)                    'Removing quotations
    StrCleaning = SplitData(i)                                              'Return clean string
    
End Function

问题根源 #

你用Print #1, Test,时，VBA默认用制表符分隔列，若输出是CSV格式，制表符不会被识别为列分隔符，导致所有内容挤在同一列。另外，逐单元格写入会增加IO开销，效率较低。

修正方案 #

将每行的数组元素用逗号拼接成单个字符串，一次性写入整行；同时优化数组索引逻辑，避免潜在越界问题。

修改后的完整代码 #

Option Explicit

Sub Test()

    Application.ScreenUpdating = False
    Application.DisplayAlerts = False
    Application.Calculation = xlCalculationManual
    
    Dim h                   As Integer:           h = 0
    Dim i                   As Integer:           i = 0
    Dim j                   As Integer:           j = 0
    Dim k                   As Integer:           k = 0
    Dim wsf                 As WorksheetFunction: Set wsf = Application.WorksheetFunction
    Dim wb                  As Workbook:          Set wb = ThisWorkbook
    Dim ws                  As Worksheet:         Set ws = wb.Worksheets(1)
    Dim FileArray()         As Variant, _
        SplitDataAgain()    As Variant, _
        SplitData()         As String, _
        CopiedData          As String, _
        CleanStr            As String, _
        fPath1              As String, _
        fPath2              As String
        fPath2 = "[OUTPUT FILE]" '替换为实际输出路径
        fPath1 = "[INPUT FILE]"  '替换为实际输入路径
    
    Dim rowContent          As String
            
    '读取输入文件
    Open fPath1 For Binary Access Read As #1
        CopiedData = Space(LOF(1))
        Get #1, , CopiedData
    Close #1

    '解析并清理数据
    SplitData() = Split(CopiedData, vbCrLf)
    Do While i <= UBound(SplitData()) - 1
        If Trim(SplitData(i)) <> "" Then '跳过空行
            CleanStr = StrCleaning(i, SplitData())
            ReDim Preserve SplitDataAgain(i)
            SplitDataAgain(i) = Split(SplitData(i), ",")
            
            k = UBound(SplitDataAgain(0))
            h = UBound(SplitDataAgain())
        End If
        i = i + 1
    Loop
    ReDim FileArray(k, h)
    
    '转置数组
    For i = 0 To h
        For j = 0 To k
            FileArray(j, i) = SplitDataAgain(i)(j)
        Next j
    Next i
    
    '写入工作表（可选保留）
    ws.Range(ws.Cells(1, 1), ws.Cells(h + 1, k + 1)) = wsf.Transpose(FileArray())
    
    '写入输出文件
    Open fPath2 For Output As #1
        For i = 0 To h
            rowContent = ""
            '拼接当前行的所有元素为逗号分隔的字符串
            For j = 0 To k
                rowContent = rowContent & FileArray(j, i)
                If j <> k Then rowContent = rowContent & ","
            Next j
            '写入整行
            Print #1, rowContent
        Next i
    Close #1
    
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Application.Calculation = xlCalculationAutomatic

End Sub

Private Function StrCleaning(i As Integer, SplitData() As String) As String

    Dim rx1                  As RegExp:           Set rx1 = New RegExp
    Dim rx2                  As RegExp:           Set rx2 = New RegExp
    Dim FindStr1             As String:           FindStr1 = "((?:^|,)\\""[^"\\",]*),"
    Dim FindStr2             As String:           FindStr2 = "(?:[\\""\""]*)([.]*)(?:[\\""\""]*)"
    Dim ReplaceStr           As String:           ReplaceStr = "$1"
    Dim p                    As Integer
    
    With rx1
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = FindStr1
    End With
    With rx2
        .Global = True
        .MultiLine = True
        .IgnoreCase = False
        .Pattern = FindStr2
    End With
    
    For p = 1 To 3
        SplitData(i) = rx1.Replace(SplitData(i), ReplaceStr)
    Next p
    SplitData(i) = rx2.Replace(SplitData(i), ReplaceStr)
    
    StrCleaning = SplitData(i)
    
End Function

关键修改说明 #

1. 行内容拼接：用rowContent变量拼接每行的所有元素，用逗号分隔，避免制表符导致的列识别问题
2. 空行处理：增加空行判断，避免写入无效空行
3. IO优化：整行写入减少文件操作次数，提升效率
4. 索引逻辑修正：调整循环条件，避免因空行导致的数组越界

内容的提问来源于stack exchange，提问作者Geoffrey Turner