Excel VBA导入.qtx文件时等号分隔符失效问题排查

我有包含逗号、制表符和等号分隔符的.qtx文件，示例数据为"STD_Gloss=4.08"，希望通过等号将4.08拆分到单独单元格。此前代码可正常运行，当前虽能导入该文件并保存为.xlsx格式，但等号分隔符未生效。

问题代码片段 #

Workbooks.OpenText filename:=folderPath & "\" & filename, Origin:=437, StartRow:= _
1, DataType:=xlDelimited, TextQualifier:=xlDoubleQuote, _
ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=True, _
Space:=False, Other:=True, OtherChar:="=", FieldInfo:=Array(Array(1, 1), _
Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True

完整宏代码 #

Sub ImportQTXSaveAsXLSX()
    Dim folderPath As String
    Dim savefolderPath As String
    Dim sourceWB As Workbook
    Dim sourceWS As Worksheet
    Dim filename As String
    
    folderPath = "U:\Macro for Gloss-O-Metre\QTX Raw"
    savefolderPath = "U:\Macro for Gloss-O-Metre\XLSX from QTX"
    
    If Right(folderPath, 1) <> "\" Then
        folderPath = folderPath & "\" 
    End If
    
    If Right(savefolderPath, 1) <> "\" Then
        folderPath = folderPath & "\" 
    End If
    
    filename = Dir(folderPath & "*.qtx")
    
    Do While filename <> "" 
        Set sourceWB = Workbooks.Open(folderPath & "\" & filename)
                
        Workbooks.OpenText filename:=folderPath & "\" & filename, Origin:=437, StartRow:= _
        1, DataType:=xlDelimited, ConsecutiveDelimiter:=False, Tab:=True, Semicolon:=False, Comma:=True, _
        Space:=False, Other:=True, OtherChar:="=", FieldInfo:=Array(Array(1, 1), _
        Array(2, 1), Array(3, 1)), TrailingMinusNumbers:=True
        
        sourceWB.SaveAs savefolderPath & "\" & filename & ".xlsx", xlOpenXMLWorkbook
        sourceWB.Close SaveChanges:=False 
        filename = Dir     
End Sub

1. 重复打开文件且未关联处理后的工作簿：代码先通过Workbooks.Open直接打开原始文件并赋值给sourceWB，随后调用Workbooks.OpenText以分隔规则重新打开文件，但后续保存、关闭操作仍针对第一个未处理的sourceWB，完全没用到处理过分隔的工作簿，导致等号分隔效果未生效。
2. 保存路径处理错误：第二个路径判断语句中，错误修改了folderPath而非savefolderPath，会导致保存路径混乱，甚至保存失败。
3. FieldInfo数组列数不匹配：示例数据通过等号仅能拆分为2列，但代码中FieldInfo设置了3列，多余的列定义可能干扰Excel自动识别逻辑。

Sub ImportQTXSaveAsXLSX()
    Dim folderPath As String
    Dim savefolderPath As String
    Dim sourceWB As Workbook
    Dim filename As String
    
    folderPath = "U:\Macro for Gloss-O-Metre\QTX Raw"
    savefolderPath = "U:\Macro for Gloss-O-Metre\XLSX from QTX"
    
    ' 处理源路径末尾的斜杠
    If Right(folderPath, 1) <> "\" Then
        folderPath = folderPath & "\"
    End If
    
    ' 处理保存路径末尾的斜杠（修正原错误）
    If Right(savefolderPath, 1) <> "\" Then
        savefolderPath = savefolderPath & "\"
    End If
    
    filename = Dir(folderPath & "*.qtx")
    
    Do While filename <> ""
        ' 直接用OpenText打开并应用分隔规则
        Workbooks.OpenText filename:=folderPath & filename, _
            Origin:=437, StartRow:=1, DataType:=xlDelimited, _
            TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
            Tab:=True, Semicolon:=False, Comma:=True, Space:=False, _
            Other:=True, OtherChar:="=", _
            FieldInfo:=Array(Array(1, 1), Array(2, 1)), ' 匹配等号分隔后的2列
            TrailingMinusNumbers:=True
        Set sourceWB = ActiveWorkbook ' 获取处理后的工作簿
        
        ' 保存为xlsx并关闭，替换冗余后缀
        sourceWB.SaveAs savefolderPath & Replace(filename, ".qtx", ".xlsx"), xlOpenXMLWorkbook
        sourceWB.Close SaveChanges:=False
        
        filename = Dir
    Loop
End Sub

• 移除多余的Workbooks.Open调用，直接通过Workbooks.OpenText处理文件，并将处理后的工作簿赋值给sourceWB
• 修正保存路径的判断逻辑，确保修改的是savefolderPath
• 调整FieldInfo为2列配置，匹配等号分隔后的列数
• 用Replace函数替换文件后缀，避免生成xxx.qtx.xlsx这类冗余文件名

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