Import txt files with UTF-8 special characters to xlsx

Question

I have txt files that are automatically exported to me from another system (I cannot change this system). When I try to convert these txt files to excel with the following code (I created a subfolder xlsx manually):

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

it does work, however certain special characters, like ä,ö and Ü and so, are not properly displayed. I.e. when I open the xlsx files later on, I can see that these have been replaced by something like ä and so. I could use a work around and now start to replace these afterwards, however I would like to improve my txt to xlsx code. According to this post or this one it should be possible using ADODB.Stream. However, I don't know how to implement this into my code (loop) to get it working here in my case? If there is another approach instead of ADOB.Stream I am also fine with that. It is not necessary for me to use ADOB.Stream.

Answer 1

Have you tried coercing the code page, using the Origin parameter? I don't know if you need a particular one, but the UTF-8 constant might be a starting point. I personally like this page as a reference source: https://learn.microsoft.com/en-us/windows/win32/intl/code-page-identifiers

So the solution might turn out to be as simple as this - it worked in my dummy tests:

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

Assuming that these txt files are tab delimited.

The handling of the characters or code page it's managed by the Origin parameter of the Workbooks.OpenText method or by the TextFilePlatform property of the QueryTable object.

These txt files should be opened with Workbooks.OpenText method, however in order to handle problem of the Decimal.Separator been different than then one in your system, I suggest to use the QueryTable method also applied to the tab separated files with a csv extension.

We just need to replace these lines:

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

With these:

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

No changes to Procedure `Open_Csv_As_Tab_Delimited_Then_Save_As_Xls, perhaps a change in the name to reflect its versatility.

Tested with this tst file:

Generated this `xlsx' file:

Hopefully, it should be straightforward to add these procedure to you project, let me know of any problem or question you might have with the resources used.

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