Meerdere TXT files inlezen in excel werkblad

[jesperarts]

Goedemiddag,

Per dag krijgen we een paar txt files met bestellingen binnen. Nu willen we die graag tegelijk inlezen in excel en onder elkaar zetten. Ik heb geprobeerd via een macro de import van 1 txt file in te lezen maar ik kan niet vinden hoe ik dit kan aanpassen zodat ik ze automatisch allemaal ingelezen kan krijgen, nu is de import gekoppeld aan de ingelezen txt file.

De bestanden hebben allemaal dezelfde opmaak en we willen alle data vanaf regel 4 inlezen.

De code die nu is opgenomen:

Sub Macro2()
'
' Macro2 Macro
'

'
    With ActiveSheet.QueryTables.Add(Connection:= _
        "TEXT;C:\test\100059-6057-20160601.TXT", Destination:=Range("$A$1"))
        .CommandType = 0
        .Name = "100059-6057-20160601"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .TextFilePromptOnRefresh = False
        .TextFilePlatform = 850
        .TextFileStartRow = 4
        .TextFileParseType = xlDelimited
        .TextFileTextQualifier = xlTextQualifierDoubleQuote
        .TextFileConsecutiveDelimiter = False
        .TextFileTabDelimiter = False
        .TextFileSemicolonDelimiter = True
        .TextFileCommaDelimiter = False
        .TextFileSpaceDelimiter = False
        .TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1)
        .TextFileTrailingMinusNumbers = True
        .Refresh BackgroundQuery:=False
    End With
    Range("A24").Select
End Sub

Ik hoop dat iemand me hier mee kan helpen

 

[edmoor]

Voer deze eens uit in een nieuw document:

Sub LeesBestand()
    Dim Regel As String
    Dim Gegevens() As String
    Dim Teller As Long

    Open "C:\test\999999-6056-20160601.TXT" For Input As #1
    Application.ScreenUpdating = False
    While Not EOF(1)
        Teller = Teller + 1
        Line Input #1, Regel
        If Teller = 3 Then
            Gegevens = Split(Regel, ";")
            Sheets("Blad1").Range("A1:G1").Value = Gegevens()
        End If
        If Teller > 3 Then
            Gegevens = Split(Regel, ";")
            With Sheets("Blad1")
                For i = 1 To 7
                    .Cells(Teller - 2, i).Value = Gegevens(i - 1)
                    If i = 3 Then .Cells(Teller - 2, 3).NumberFormat = "#0"
                Next i
            End With
        End If
    Wend
    
    Close #1
    Columns.AutoFit
    Application.ScreenUpdating = True
End Sub

Je kan ook het .txt bestand hernoemen naar .csv en hem dan openen met Excel.

 

[jesperarts]

Hoi Edmoor,

Bedankt voor de snelle reactie. Dit gaat idd goed. De vraag was eigenlijk ook dat ik zo een stuk of 8 of 9 bestanden per dag in een map heb staan die ik in 1x autmatisch wil inlezen, ze hebben alleen allemaal andere benamingen. Kunnen we de Open "C:\test\999999-6056-20160601.TXT" op een of andere manier vervangen zodat deze al de bestanden die in de map staan inlezen?

Ik had eerst deze code gevonden op het forum, maar die zet het hele tekst bestand in 1 cel. Jouw macro doet het precies goed maar als we het zouden combineren met het ophalen van alle txt bestanden dan zou het compleet zijn

Sub test()
    Dim myDir As String, fn As String, txt As String, x
    myDir = "C:\Imports\"
    fn = Dir(myDir & "\*.txt")
    Do While fn <> ""
        txt = CreateObject("Scripting.FileSystemObject").OpenTextFile(myDir & "\" & fn).ReadAll
        x = Application.Transpose(Split(txt, vbCrLf))
        Sheets(1).Range("a" & Rows.Count).End(xlUp)(2).Resize(UBound(x, 1)).Value = x
        Sheets(1).Range("b" & Rows.Count).End(xlUp)(2).Resize(UBound(x, 1)).Value = fn
        fn = Dir()
    Loop
End Sub

Fijne avond alvast!

 

[edmoor]

Probeer dit eens. Er zit geen foutafhandeling in.

Option Explicit

Sub TXTfiles()
    Dim Pad As String
    Dim Bestand As String
    
    Pad = "C:\Test\"
    Bestand = Dir(Pad & "*.txt")
    
    Application.ScreenUpdating = False
    With Sheets("Blad1")
        .Cells(1, 1) = "REGELNR:"
        .Cells(1, 2) = "AANTAL:"
        .Cells(1, 3) = "BARCODE:"
        .Cells(1, 4) = "LEV.NUMMER:"
        .Cells(1, 5) = "OMSCHRIJVING:"
        .Cells(1, 6) = "INTERN.NR:"
        .Cells(1, 7) = "Order.NR:"
    End With
    
    While Bestand <> ""
        Call LeesBestand(Pad & Bestand)
        Bestand = Dir()
    Wend

    Application.ScreenUpdating = True
    Sheets("Blad1").Columns.AutoFit
End Sub

Sub LeesBestand(Bestand As String)
    Dim Regel As String
    Dim Gegevens() As String
    Dim Teller As Long
    Dim i As Byte
    
    With Sheets("Blad1")
        Teller = .Cells(.Rows.Count, "A").End(xlUp).Row
    End With
    
    Open Bestand For Input As #1
    Line Input #1, Regel
    Line Input #1, Regel
    Line Input #1, Regel
    While Not EOF(1)
        Teller = Teller + 1
        Line Input #1, Regel
        Gegevens = Split(Regel, ";")
        With Sheets("Blad1")
            For i = 1 To 7
                .Cells(Teller, i).Value = Gegevens(i - 1)
                If i = 3 Then .Cells(Teller, 3).NumberFormat = "#0"
            Next i
        End With
    Wend
    Close #1
End Sub

 

[jesperarts]

Werkt perfect! Precies waar ik naar op zoek ben. Denk dat het wel goed komt met de foutoplossing, de bestanden zijn altijd gelijk en als ze dat niet zijn en hij loopt fout dan weten we ook meteen dat er een probleem is met het systeem.

Nogmaals bedankt voor de snelle reactie en voor de super oplossing!

 

[edmoor]

Graag gedaan