Excel VBA Import TXT File with variable Column width

Question

I have a challenge with importing fixed with files (TXT) into Excel via VBA. The Issue is not really getting the Data into Excel (Code below) but change the column width depending on the column content of the TXT file.

Any Help is much appriciated !!

Example:

The Content of the txt File is:

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

Depending on the content of the first Column (FirstC ) the import column width in Excel should change, i.e. for A the Column width of the Second Column (SecondC) should be 8 digits and in Case of an B it should be 10 Digits

The import Code (not a pro, so sorry if the code is a bit messy):

    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

below my code a bit modded and it works except that the fourth Column is not displayed. Actually more columns will be added so would be great to see where i have to tweak the code in order to be flexible with Columns. Any Idea? Thanks in advance

Textfile (only 2 Lines, will be more in the future) looks like this:

0000000002666980001F2002
0000000002666980002G1020709500430120101L05200000000000000000000

Coding:

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

End Sub

To handle this in a single import you'd need to "manually" read the file line by line and check the first column to see how to handle the next columns. Or you could run the code you have twice - first time with setting1 (then deleting any "B" rows) then again with setting2 (deleting any "A" rows). — Tim Williams, Aug 06 '12 at 18:39
Have you tried using space/tab delimiters (treating consecutive delimiters as a single one)? You might find that your column headers are pushed one column to the right, but you can easily cut+paste them over one cell with VBA. — Zairja, Aug 06 '12 at 20:53
All, many Thanks for your feedback. Zairja: The source file is a fixed witdh file so i can't change that (its from our ERP system). @Tim Williams: Reading line by line is someting i assumed would be a solution but unfortunately i'm still learning so any code example would be very helpful :) — Dennis, Aug 07 '12 at 05:31

Tim Williams · Accepted Answer · 2012-08-21T14:57:59.987

Untested:

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

Thanks, that actually worked in the first go. I will test it a little bit more in detail some time over the next 2 days and will report back if everything worked out. So far many Thanks and thumbs up!! — Dennis, Aug 07 '12 at 14:40
Added my modded Code but still ned some help. Many Thanks in advance — Dennis, Aug 16 '12 at 12:17
Last Question: As much as I understand the Array gets filled with all the Values and also describes the Excel Cell in which the value gets pasted. How can I paste the values only in certain cells and maintain the original content which is already in the cell? Example: .Value = Array(f1, , f3) where the missing f2 represents a cell in the excel sheet which is already filled and should stay like it is — Dennis, Aug 21 '12 at 13:12

Excel VBA Import TXT File with variable Column width

1 Answers1