如何用VBA在Excel中导入符合RFC4180标准的CSV并保留原始格式

核心需求 #

• 严格遵循RFC4180规范：保留引号包裹字段内的换行、正确解析转义的双引号
• 所有内容以纯文本导入，禁止自动转换数字、日期等格式

现有方法的缺陷 #

Excel原生方法无法同时满足上述两个需求：

• Workbooks.Open：能保留引号内的换行，但会自动转换数字（如"00444"变为444）和日期，且转换后无法恢复原始文本
• QueryTables.Add：可强制设置文本格式，但会将引号内的换行拆分为多行，违反RFC4180规范
• Workbooks.OpenText/Range.TextToColumns：字段格式参数失效，仍会自动转换数字和日期

解决方案：自定义RFC4180解析器 #

通过手动编写CSV解析逻辑，严格遵循RFC4180的2.6和2.7条款，实现纯文本导入并保留引号内的换行。

完整VBA代码 #

解析CSV的核心函数

Private Function ParseRFC4180CSV(strFilePath As String) As Variant
    Dim fileNum As Integer, fileContent As String
    Dim char As String, currentField As String
    Dim inQuotes As Boolean, rows As Collection, fields As Collection
    Dim i As Integer
    
    Set rows = New Collection
    Set fields = New Collection
    inQuotes = False
    currentField = ""
    
    ' 读取完整文件内容
    fileNum = FreeFile
    Open strFilePath For Input As #fileNum
    fileContent = Input$(LOF(fileNum), fileNum)
    Close #fileNum
    
    ' 逐字符解析CSV
    For i = 1 To Len(fileContent)
        char = Mid$(fileContent, i, 1)
        
        Select Case char
            Case """"
                If inQuotes Then
                    ' 处理转义双引号（连续两个双引号）
                    If i < Len(fileContent) And Mid$(fileContent, i + 1, 1) = """" Then
                        currentField = currentField & """"
                        i = i + 1 ' 跳过第二个双引号
                    Else
                        inQuotes = False ' 退出引号包裹状态
                    End If
                Else
                    inQuotes = True ' 进入引号包裹状态
                End If
            Case ","
                If Not inQuotes Then
                    ' 非引号内的逗号视为字段分隔符
                    fields.Add currentField
                    currentField = ""
                Else
                    ' 引号内的逗号作为普通字符保留
                    currentField = currentField & char
                End If
            Case vbCr
                ' 仅处理CRLF组合作为行分隔符
                If i < Len(fileContent) And Mid$(fileContent, i + 1, 1) = vbLf Then
                    If Not inQuotes Then
                        ' 非引号内的CRLF视为行结束
                        fields.Add currentField
                        rows.Add fields
                        Set fields = New Collection
                        currentField = ""
                        i = i + 1 ' 跳过LF
                    Else
                        ' 引号内的CRLF作为普通换行保留
                        currentField = currentField & vbCrLf
                        i = i + 1 ' 跳过LF
                    End If
                End If
            Case vbLf
                ' 兼容单独的LF作为行分隔符
                If Not inQuotes Then
                    fields.Add currentField
                    rows.Add fields
                    Set fields = New Collection
                    currentField = ""
                Else
                    currentField = currentField & vbLf
                End If
            Case Else
                currentField = currentField & char
        End Select
    Next i
    
    ' 处理最后一行的剩余字段
    If currentField <> "" Or fields.Count > 0 Then
        fields.Add currentField
        rows.Add fields
    End If
    
    ' 将集合转换为二维数组，方便写入工作表
    Dim resultArr() As String
    ReDim resultArr(1 To rows.Count, 1 To GetMaxFields(rows))
    
    Dim rowIdx As Integer, fieldIdx As Integer
    For rowIdx = 1 To rows.Count
        Set fields = rows(rowIdx)
        For fieldIdx = 1 To fields.Count
            resultArr(rowIdx, fieldIdx) = fields(fieldIdx)
        Next fieldIdx
    Next rowIdx
    
    ParseRFC4180CSV = resultArr
End Function

' 辅助函数：获取CSV的最大列数
Private Function GetMaxFields(rows As Collection) As Integer
    Dim maxCols As Integer, fields As Collection
    maxCols = 0
    For Each fields In rows
        If fields.Count > maxCols Then maxCols = fields.Count
    Next fields
    GetMaxFields = maxCols
End Function

导入到工作表的函数

Public Sub ImportRFC4180CSVToSheet(strFilePath As String, wsDest As Worksheet)
    Dim csvData As Variant
    Dim destRange As Range
    
    ' 解析CSV数据
    csvData = ParseRFC4180CSV(strFilePath)
    If IsEmpty(csvData) Then Exit Sub
    
    ' 清空目标工作表（可选操作）
    wsDest.Cells.Clear
    
    ' 定义目标区域并设置为文本格式
    Set destRange = wsDest.Range(wsDest.Cells(1, 1), wsDest.Cells(UBound(csvData, 1), UBound(csvData, 2)))
    destRange.NumberFormat = "@"
    
    ' 写入解析后的纯文本数据
    destRange.Value = csvData
    
    ' 自动调整列宽
    destRange.EntireColumn.AutoFit
End Sub

使用示例 #

Sub TestCSVImport()
    Dim csvFilePath As String
    Dim targetWorksheet As Worksheet
    
    ' 替换为你的CSV文件路径
    csvFilePath = "C:\Users\YourName\Documents\test.csv"
    ' 替换为目标工作表
    Set targetWorksheet = ThisWorkbook.Worksheets("ImportResult")
    
    ' 执行导入
    ImportRFC4180CSVToSheet csvFilePath, targetWorksheet
End Sub

代码优势 #

• 完全遵循RFC4180规范，正确处理引号内的换行、转义双引号和字段内的逗号
• 所有内容以纯文本形式导入，无任何自动格式转换，保留原始字符串
• 兼容各种边缘场景（如空字段、以引号开头的字段、特殊日期格式字符串等）

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