2

我有从另一个系统自动导出给我的 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

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

4

2 回答 2

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
于 2020-11-16T06:43:25.580 回答
1

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

字符的处理或由Workbooks.OpenText 方法code page的Origin参数或对象的TextFilePlatform 属性管理 。QueryTable

这些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

…</p> 

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
于 2020-11-17T19:40:19.143 回答