将带有 UTF-8 特殊字符的 txt 文件导入到 xlsx

Question

我有从另一个系统自动导出给我的 txt 文件（我无法更改这个系统）。当我尝试使用以下代码将这些 txt 文件转换为 excel 时（我手动创建了一个子文件夹 xlsx）：

Sub all()

   Dim sourcepath As String
   Dim sDir As String
   Dim newpath As String
    
    sourcepath = "C:\Users\PC\Desktop\Test\"
    newpath = sourcepath & "xlsx\"
    
    'make sure subfolder xlsx was created before

    sDir = Dir$(sourcepath & "*.txt", vbNormal)
    Do Until Len(sDir) = 0
        Workbooks.Open (sourcepath & sDir)
        With ActiveWorkbook
            .SaveAs Filename:=Replace(Left(.FullName, InStrRev(.FullName, ".")), sourcepath, newpath) & "xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False
            .Close
        End With
        
        sDir = Dir$
    Loop
End Sub

它确实有效，但是某些特殊字符，如 ä、ö 和 Ü 等，无法正确显示。 IE。当我稍后打开 xlsx 文件时，我可以看到这些文件已被 ä 等替换。我可以使用解决方法，现在开始替换这些，但是我想改进我的 txt 到 xlsx 代码。根据这个post 或这个one 应该可以使用ADODB.Stream。但是，我不知道如何在我的代码（循环）中实现它以使其在我的情况下在这里工作？如果有另一种方法而不是 ADOB.Stream 我也很好。我不需要使用 ADOB.Stream。

Answer 1

您是否尝试过使用Origin 参数强制代码页？我不知道您是否需要一个特定的，但 UTF-8 常量可能是一个起点。我个人喜欢这个页面作为参考来源：https://docs.microsoft.com/en-us/windows/win32/intl/code-page-identifiers

所以解决方案可能会像这样简单 - 它在我的虚拟测试中有效：

Option Explicit
Private Const CP_UTF8 As Long = 65001

Public Sub RunMe()
    Dim sDir As String, sourcePath As String, fileName As String
    Dim fso As Object
    
    sourcePath = "C:\anyoldpath\"
    
    Set fso = CreateObject("Scripting.FileSystemObject")
    sDir = Dir(sourcePath & "*.txt", vbNormal)
    Do While Len(sDir) > 0
        fileName = sourcePath & "xlsx\" & fso.GetBaseName(sDir) & ".xlsx"
        Application.Workbooks.OpenText sourcePath & sDir, CP_UTF8
        ActiveWorkbook.SaveAs fileName, xlOpenXMLWorkbook
        ActiveWorkbook.Close False
        sDir = Dir()
    Loop
End Sub

Answer 2

假设这些txt 文件是制表符分隔的。

字符或code page 的处理由Workbooks.OpenText method 的Origin 参数或QueryTable 对象的TextFilePlatform property 管理。

这些txt文件应该用Workbooks.OpenText方法打开，但是为了处理Decimal.Separator与你系统中的那个不同的问题，我建议使用QueryTable方法也适用于带有csv 扩展名的制表符分隔文件。

我们只需要替换这些行：

sFile = Dir$(sPathSrc & "*.csv")
    sFilenameTrg = sPathTrg & Left(sFile, InStrRev(sFile, ".csv")) & "xlsx"

有了这些：

sFile = Dir$(sPathSrc & "*.txt")
    sFilenameTrg = sPathTrg & Left(sFile, InStrRev(sFile, ".txt")) & "xlsx"

过程 `Open_Csv_As_Tab_Delimited_Then_Save_As_Xls 没有变化，可能是名称的变化以反映其多功能性。

用这个tst 文件测试：

生成了这个 `xlsx' 文件：

希望将这些过程添加到您的项目中应该很简单，如果您对所使用的资源有任何问题或疑问，请告诉我。

Sub Tab_Delimited_UTF8_Files_Save_As_Xlsx()
Dim sFilenameSrc As String, sFilenameTrg As String
Dim sPathSrc As String, sPathTrg As String
Dim sFile As String
Dim bShts As Byte, exCalc As XlCalculation

    sPathSrc = "C:\Users\PC\Desktop\Test\"
    sPathTrg = sPathSrc & "xlsx\"

    Rem Excel Properties OFF
    With Application
        .EnableEvents = False
        .DisplayAlerts = False
        .ScreenUpdating = False
        exCalc = .Calculation
        .Calculation = xlCalculationManual
        .CalculateBeforeSave = False
        bShts = .SheetsInNewWorkbook
        .SheetsInNewWorkbook = 1
    End With

    Rem Validate Target Folder
    If Len(Dir$(sPathTrg, vbDirectory)) = 0 Then MkDir sPathTrg

    Rem Process Csv Files
    sFile = Dir$(sPathSrc & "*.txt")
    Do Until Len(sFile) = 0
        
        sFilenameSrc = sPathSrc & sFile
        sFilenameTrg = sPathTrg & Left(sFile, InStrRev(sFile, ".txt")) & "xlsx"
        
        Call Open_Csv_As_Tab_Delimited_Then_Save_As_Xls(sFilenameSrc, sFilenameTrg)
        
        sFile = Dir$
    
    Loop

    Rem Excel Properties OFF
    With Application
        .SheetsInNewWorkbook = bShts
        .Calculation = exCalc
        .CalculateBeforeSave = True
        .ScreenUpdating = True
        .DisplayAlerts = True
        .EnableEvents = True
    End With
    
    End Sub

…

Sub Open_Txt_As_Tab_Delimited_Then_Save_As_Xls(sFilenameSrc As String, sFilenameTrg As String)
Dim Wbk As Workbook
    
    Rem Workbook - Add
    Set Wbk = Workbooks.Add(Template:="Workbook")
    With Wbk
    
        Rem Txt File - Import
        With .Worksheets(1)
            
            Rem QueryTable - Add
            With .QueryTables.Add(Connection:="TEXT;" & sFilenameSrc, Destination:=.Cells(1))
                
                Rem QueryTable - Properties
                .SaveData = True
                .TextFileParseType = xlDelimited
                .TextFileDecimalSeparator = "."
                .TextFileThousandsSeparator = ","
                .TextFileConsecutiveDelimiter = False
                .TextFileTabDelimiter = True
                .TextFileTrailingMinusNumbers = True
                .TextFilePlatform = 65001       'Unicode (UTF-8)
                .Refresh BackgroundQuery:=False
                
                Rem QueryTable - Delete
                .Delete
            
        End With: End With

        Rem Workbook - Save & Close
        .SaveAs Filename:=sFilenameTrg, FileFormat:=xlOpenXMLWorkbook
        .Close
    
    End With

    End Sub