Excel VBA Import von TXT-Datei mit variabler Spaltenbreite

Habe ich eine Herausforderung mit dem Import von festen mit Dateien (TXT) in Excel über VBA. Das Problem ist nicht wirklich die Daten in Excel (Code unten), aber ändern die Spaltenbreite ist abhängig von der Spalte Inhalt der TXT-Datei.

Jede Hilfe ist sehr appriciated !!

Beispiel:

Den Inhalt der txt-Datei ist:

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

Je nach Inhalt der ersten Spalte (FirstC ) die Einfuhr Spaltenbreite in Excel ändern sollte, also die Spaltenbreite der Zweiten Spalte (SecondC) sollte 8-stellig und im Falle einer B es sollte 10-Stellig

Der import-Code (kein Profi, also sorry wenn der code ein wenig unübersichtlich):

    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

unten mein code ein bisschen modded und es funktioniert mit Ausnahme, dass die vierte Spalte wird nicht angezeigt.
Eigentlich mehr Spalten Hinzugefügt werden, so groß sein würde, um zu sehen, wo muss ich den code optimieren, um flexibel zu sein mit den Spalten. Irgendeine Idee? Vielen Dank im Voraus

Textdatei (nur 2 Linien, die werden mehr in der Zukunft) sieht wie folgt aus:

0000000002666980001F2002
0000000002666980002G1020709500430120101L05200000000000000000000

Kodierung:

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

Behandeln Sie diese in einem einzigen import müssten Sie "manuell", Lesen Sie die Datei zeilenweise ein und überprüfen Sie die erste Spalte, um zu sehen, wie man mit den nächsten Spalten. Oder man könnte den code hast du zweimal - das erste mal mit setting1 (dann löschen Sie alle "B" - Zeilen), dann wieder mit setting2 (löschen alle "A" - Zeilen).
Haben Sie versucht, mit space/tab-Trennzeichen (Behandlung aufeinander folgende Trennzeichen als ein einziger)? Sie werden feststellen, dass Sie Ihre Spaltenüberschriften geschoben werden, um eine Spalte nach rechts, aber Sie lässt sich leicht schneiden+fügen Sie einer Zelle mit VBA.
Alle, vielen Dank für dein feedback. Zairja: Die Quell-Datei ist ein fixed witdh-Datei, so kann ich das nicht ändern (seine aus unserem ERP-system). @Tim Williams: Lesen Sie Zeile für Zeile ist etwas ich davon ausgegangen, wäre eine Lösung, aber leider bin ich noch zu lernen, so dass jede code-Beispiel wäre sehr hilfreich 🙂

InformationsquelleAutor Dennis | 2012-08-06

Ungetestet:

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

Danke, das hat tatsächlich funktioniert in der ersten gehen. Ich werde es testen, ein wenig mehr im detail einige Zeit über die nächsten 2 Tage und werde berichten, wenn alles geklappt hat. So weit vielen Dank und Daumen hoch!!
Hinzugefügt meine modifizierten Code, der aber noch ned etwas Hilfe. Vielen Dank im Voraus
Letzte Frage: Wie viel, wie, ich verstehe das Array gefüllt wird, mit allen Werten und beschreibt auch die Excel Zelle, in der der Wert wird eingefügt. Wie kann ich das einfügen die Werte nur in bestimmte Zellen und Erhaltung der ursprünglichen Inhalt, der bereits in der Zelle? Beispiel: .Wert = Array(f1 , f3), wo die fehlende f2 steht für eine Zelle im excel-Blatt, das bereits gefüllt ist und sollte bleiben wie es ist
Siehe mein edit, wie das zu tun.
Perfekt!! Das funktionierte

InformationsquelleAutor Tim Williams

Schreibe einen Kommentar

Du musst angemeldet sein, um einen Kommentar abzugeben.