Excel VBA 导入具有可变列宽的文本文件

Question

我在通过 VBA 将固定文件 (TXT) 导入 Excel 时遇到了挑战。问题并不是真正将数据导入 Excel（代码如下），而是根据 TXT 文件的列内容更改列宽。

非常感谢任何帮助！

例子：

txt文件的内容是：

  FirstC        SecondC           ThirdC
A             111122223333      444455556666
B             111122223333      444455556666
A             111122223333      444455556666
A             111122223333      444455556666
B             111122223333      444455556666

根据第一列 (FirstC) 的内容，Excel 中的导入列宽应更改，即对于 A，第二列 (SecondC) 的列宽应为 8 位，如果是 B，则应为 10数字

导入代码（不是专业的，如果代码有点乱，请见谅）：

    Sub Button1_Click()

Dim vPath As Variant

vPath = Application.GetOpenFilename("TextFiles (*.txt), *.txt", , "TEST TEXT IMPORTER:")
If vPath = False Then Exit Sub
Filename = vPath
Debug.Print vPath

Worksheets("IMPORT").UsedRange.ClearContents


With Sheets("IMPORT").QueryTables.Add(Connection:="TEXT;" & CStr(vPath), Destination:=Sheets("IMPORT").Range("A2"))
       .FieldNames = True
       .RowNumbers = False
       .FillAdjacentFormulas = False
       .PreserveFormatting = True
       .RefreshOnFileOpen = False
       .RefreshStyle = xlInsertDeleteCells
       .SavePassword = False
       .SaveData = True
       .AdjustColumnWidth = True
       .RefreshPeriod = 0
       .TextFilePromptOnRefresh = False
       .TextFilePlatform = xlWindows
       .TextFileStartRow = 1
       .TextFileParseType = xlFixedWidth
       .TextFileTextQualifier = xlTextQualifierDoubleQuote
       .TextFileConsecutiveDelimiter = False
       .TextFileTabDelimiter = False
       .TextFileSemicolonDelimiter = False
       .TextFileCommaDelimiter = False
       .TextFileSpaceDelimiter = False
       .TextFileColumnDataTypes = Array(2, 2, 2)
       .TextFileFixedColumnWidths = Array(14, 18, 12)  
       .TextFileFixedColumnWidths = Array(14, 18, 12)    '<-- That’s where  I need to be flexible
       .TextFileTrailingMinusNumbers = True
       .Refresh BackgroundQuery:=False

   End With


End Sub

---

在我的代码下面进行了一些修改，除了第四列没有显示之外它可以工作。 实际上将添加更多列，因此很高兴看到我必须在哪里调整代码以便灵活使用列。任何想法？提前致谢

文本文件（只有2行，以后会更多）看起来像这样：

0000000002666980001F2002
0000000002666980002G1020709500430120101L05200000000000000000000

---

编码：

Sub Button1_Click()


    Const fPath As String = "H:\MyDocs\xxxxx\TestFiles6.txt"
    Const fsoForReading = 1
    Const F1_LEN As Integer = 15    'Reference Number
    Const F2_LEN As Integer = 4     'Cosectuive Number
    Const F3_LEN As Integer = 1     'Record Type
    Const F4_Len As Integer = 4     'Company Number

    Dim objFSO As Object
    Dim objTextStream As Object
    Dim start As Integer
    Dim fLen As Integer
    Dim rw As Long

    Set objFSO = CreateObject("scripting.filesystemobject")
    Set objTextStream = objFSO.OpenTextFile(fPath, fsoForReading)
    rw = 2

    Do Until objTextStream.AtEndOfStream
        txt = objTextStream.Readline


        f1 = Trim(Left(txt, F1_LEN))
   '------------------------------------------------------------------------------------------------------------
        start = F1_LEN + 1
        f2 = Trim(Mid(txt, start, F2_LEN))
   '------------------------------------------------------------------------------------------------------------
        start = F1_LEN + F2_LEN + 1
        f3 = Trim(Mid(txt, start, F3_LEN))

        If f3 = "F" Then
            fLen = 4
        ElseIf f3 = "G" Then
            fLen = 50
        Else

        End If

        Debug.Print start
    '------------------------------------------------------------------------------------------------------------
        start = start + 1
        f4 = Trim(Mid(txt, start, fLen))
        Debug.Print f4
    '------------------------------------------------------------------------------------------------------------
        ThisWorkbook.Sheets("data").Cells(rw, 1).Resize(1, 3).Value = Array(f1, f2, f3, f4)
        rw = rw + 1
    Loop

    objTextStream.Close

结束子

Answer 1

未经测试：

Sub Tester()

    Const fPath As String = "C:\SomeFile.txt"
    Const fsoForReading = 1
    Const F1_LEN As Integer = 14
    Const F2_LEN_A As Integer = 8
    Const F2_LEN_B As Integer = 10
    Const F3_LEN As Integer = 14

    Dim objFSO As Object, objTextStream As Object, txt, f1, f2, f3
    Dim start As Integer, fLen As Integer
    Dim rw As Long

    Set objFSO = CreateObject("scripting.filesystemobject")
    Set objTextStream = objFSO.OpenTextFile(fPath, fsoForReading)
    rw = 2

    Do Until objTextStream.AtEndOfStream
        txt = objTextStream.Readline


        f1 = Trim(Left(txt, F1_LEN))
        start = F1_LEN + 1

        If f1 = "A" Then
            fLen = 8
        ElseIf f1 = "B" Then
            fLen = 10
        Else
            'what if?
        End If

        f2 = Trim(Mid(txt, start, fLen))
        start = start + fLen + 1
        f3 = Trim(Mid(txt, start, F3_LEN))

        With ThisWorkbook.Sheets("data").Cells(rw, 1).Resize(1, 3)
            .NumberFormat = "@" 'format cells as text 
            .Value = Array(f1, f2, f3)
            'alternatively.....
            '.cells(1).Value = f1
            '.cells(3).Value = f3
        End With
        rw = rw + 1
    Loop

    objTextStream.Close
End Sub