CSV转XLSX宏代码列数据合并异常问题求助

我编写了一个Excel宏，用于将CSV文件中的数据导入到xlsm文件中。目前代码能完成CSV转XLSX格式转换并导入数据，但所有数据几乎都粘贴到同一列；而手动将CSV另存为XLSX时，数据能保持正常的列分隔状态。原代码如下，希望有人帮忙解决问题，也供其他有需要的人参考：

Sub Main()

Dim FileAddress, FileName As String
Dim FolderAddress As String
Dim oldfname, newfname As String



Dim n, z, length As Integer

    FileAddress = Application.GetOpenFilename()
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    ' Capture name of current file
    myFileName = ActiveWorkbook.Name
    
    ' Set folder name to work through
    FolderAddress = Left(FileAddress, InStrRev(FileAddress, Application.PathSeparator))
    
    Workbooks.Open FileName:=FileAddress
    
    'xlOpenXMLWorkbook
    
    oldfname = ActiveWorkbook.FullName
    newfname = FolderAddress & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & ".xlsx"
    ActiveWorkbook.SaveAs FileName:=newfname, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    'ActiveWorkbook.SaveAs FileName:=newfName, CreateBackup:=False
    ActiveWorkbook.Close
    
    Kill oldfname
    Windows(myFileName).Activate
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    
    Application.ScreenUpdating = False
    
    Set thisWB = ThisWorkbook                               'Destination Workbook
    Set thisWS = ThisWorkbook.Sheets("CSV_Information")     'Destination Worksheet

    Set thatWB = Workbooks.Open(newfname)                   'Source xlsx
    
    FileNameFull = Right(newfname, Len(newfname) - InStrRev(newfname, "\"))
    FileNameDummy = Left(FileNameFull, (InStr(FileNameFull, ".") - 1))
    
    If Len(FileNameDummy) > 31 Then
    
            FileName = Left(FileNameDummy, 31)
    
        Else
    
            FileName = FileNameDummy
    
    End If
    
    
    Set thatWS = thatWB.Sheets(FileName)                   'Source Worksheet

    Application.CutCopyMode = False

    thatWS.Range("A1:E1006").Copy
    thisWS.Range("A1:E1006").PasteSpecial xlPasteAll
    thatWB.Close
    
    n = Worksheets("CSV_Information").Range("A1:A1006").Cells.SpecialCells(xlCellTypeConstants).Count
    
    MsgBox n

    Worksheets("All_Transactions").Activate
    
    z = n + 1
    
    
    Worksheets("CSV_Information").Activate
    Range("A6:E" & z).Copy

    Worksheets("All_Transactions").Activate
    Range("5:6").Insert
    
    With ActiveSheet.Sort
        .SortFields.Add Key:=Range("A6"), Order:=xlAscending
        .SetRange Range("A6:E1006")
        .Header = xlNo
        .Apply
    End With

End Sub

问题原因 #

直接使用Workbooks.Open打开CSV文件时，Excel会依据系统区域设置自动判断分隔符，这可能与你的CSV实际使用的分隔符不匹配，导致数据无法按列拆分。而手动另存时Excel会正确识别分隔符，因此能正常分列。

修复后的代码 #

修改打开CSV的逻辑，使用Workbooks.OpenText明确指定分隔符（以下以逗号为例，若你的CSV使用分号等其他分隔符，可对应调整参数）：

Sub Main()

Dim FileAddress, FileName As String
Dim FolderAddress As String
Dim oldfname, newfname As String
Dim n, z, length As Integer
Dim thisWB As Workbook, thatWB As Workbook
Dim thisWS As Worksheet, thatWS As Worksheet
Dim FileNameFull As String, FileNameDummy As String, myFileName As String

    ' 限定仅选择CSV文件，添加取消选择的判断
    FileAddress = Application.GetOpenFilename("CSV Files (*.csv), *.csv")
    If FileAddress = "False" Then Exit Sub
    
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False
    
    ' Capture name of current file
    myFileName = ActiveWorkbook.Name
    
    ' Set folder name to work through
    FolderAddress = Left(FileAddress, InStrRev(FileAddress, Application.PathSeparator))
    
    ' 关键修改：用OpenText指定分隔符，确保数据按列拆分
    Workbooks.OpenText Filename:=FileAddress, _
        DataType:=xlDelimited, _
        Comma:=True, _ ' 逗号分隔符，若用分号则改为Semicolon:=True
        TextQualifier:=xlTextQualifierDoubleQuote ' 识别双引号包裹的文本
        
    oldfname = ActiveWorkbook.FullName
    newfname = FolderAddress & Left(ActiveWorkbook.Name, Len(ActiveWorkbook.Name) - 4) & ".xlsx"
    ActiveWorkbook.SaveAs Filename:=newfname, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
    ActiveWorkbook.Close
    
    Kill oldfname
    Windows(myFileName).Activate
    
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    
    Application.ScreenUpdating = False
    
    Set thisWB = ThisWorkbook                               'Destination Workbook
    Set thisWS = ThisWorkbook.Sheets("CSV_Information")     'Destination Worksheet

    Set thatWB = Workbooks.Open(newfname)                   'Source xlsx
    
    FileNameFull = Right(newfname, Len(newfname) - InStrRev(newfname, "\"))
    FileNameDummy = Left(FileNameFull, (InStr(FileNameFull, ".") - 1))
    
    If Len(FileNameDummy) > 31 Then
            FileName = Left(FileNameDummy, 31)
        Else
            FileName = FileNameDummy
    End If
    
    Set thatWS = thatWB.Sheets(FileName)                   'Source Worksheet

    Application.CutCopyMode = False

    thatWS.Range("A1:E1006").Copy
    thisWS.Range("A1:E1006").PasteSpecial xlPasteAll
    thatWB.Close
    
    n = Worksheets("CSV_Information").Range("A1:A1006").Cells.SpecialCells(xlCellTypeConstants).Count
    
    MsgBox n

    Worksheets("All_Transactions").Activate
    
    z = n + 1
    
    Worksheets("CSV_Information").Activate
    Range("A6:E" & z).Copy

    Worksheets("All_Transactions").Activate
    Range("5:6").Insert
    
    With ActiveSheet.Sort
        .SortFields.Add Key:=Range("A6"), Order:=xlAscending
        .SetRange Range("A6:E1006")
        .Header = xlNo
        .Apply
    End With

    ' 恢复界面更新
    Application.ScreenUpdating = True
End Sub

额外优化说明 #

• 添加了CSV文件选择的限定及用户取消选择的判断，避免无文件时报错
• 补全了所有变量的类型声明（原代码部分变量默认Variant类型）
• 最后恢复ScreenUpdating为True，确保Excel界面正常响应

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