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

我在通过VBA将fixed with files（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

---

编码：

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

末端接头未测试：

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

---

要在单个导入中处理此问题，您需要逐行“手动”读取文件，并检查第一列以了解如何处理下一列。或者您可以运行两次您拥有的代码—第一次使用setting1（然后删除任何“B”行），然后再次使用setting2（删除任何“A”行）。您是否尝试过使用空格/制表符分隔符（将连续分隔符视为单个分隔符）？您可能会发现您的列标题被推到了右侧的一列，但是您可以使用VBA轻松地将它们剪切并粘贴到一个单元格上。非常感谢您的反馈。Zairja：源文件是一个固定的witdh文件，所以我不能更改它（它来自我们的ERP系统）@Tim Williams：逐行阅读是我认为可以解决的问题，但不幸的是，我仍在学习，所以任何代码示例都会非常有用：）谢谢，这在第一步中就奏效了。在接下来的两天里，我会对它进行更详细的测试，如果一切顺利，我会向你汇报。到目前为止，非常感谢并竖起大拇指！！添加了我修改过的代码，但仍然需要一些帮助。非常感谢最后一个问题：据我所知，数组中填充了所有值，还描述了粘贴值的Excel单元格。如何仅在某些单元格中粘贴值并保持单元格中已有的原始内容？示例：.Value=数组（f1，f3），其中缺少的f2表示excel工作表中已填充且应保持原样的单元格

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