txt Dateien importieren mit Zeilenumbruch

Hallo und schönen guten Tag.
Ich habe ein Makro welches soweit funktioniert.
Ich möchte verschiedene gleichartige csv Dateien in Excel importieren.
Hierzu folgendes Makro:

Sub Rename_Files()
'(C) Ramses
'Liest alle txt-Dateien in einem Verzeichnis ein
Dim Datei As String, freeRow As Long
Dim Qe As Integer
Dim PFAD As String
PFAD = "C:\Test\" 'ACHTUNG: Bachslash am Schluss
Datei = Dir(PFAD & "*.txt")
Qe = MsgBox("Zum Import muss die aktuelle Tabelle leer sein," & vbCrLf & _
"bzw. alle Daten der aktuellen Tabelle: "" " & ActiveSheet.Name & " "" werden gelöscht", _
vbYesNo + vbCritical, "CSV-Import starten ?")
If Qe = vbNo Then
MsgBox "CSV-Import abgebrochen"
Exit Sub
Else
Cells.Clear
End If
Do While Datei  ""
freeRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
With ActiveSheet.QueryTables.Add(Connection:="TEXT;" & PFAD & Datei, Destination:=Range("A"  _
& freeRow))
.Name = Datei
.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 = 1
.TextFileParseType = xlDelimited
.TextFileTextQualifier = xlTextQualifierDoubleQuote
.TextFileConsecutiveDelimiter = False
.TextFileTabDelimiter = False
.TextFileSemicolonDelimiter = True
.TextFileCommaDelimiter = False
.TextFileSpaceDelimiter = False
.TextFileColumnDataTypes = Array(1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1, 1)
.TextFileTrailingMinusNumbers = True
.Refresh BackgroundQuery:=False
End With
Datei = Dir()
Loop
End Sub

Nun möchte ich das Makro erweitern, nur weiß ich nicht, wie ich dies machen kann.
Der Gedanke ist, das die txt Dateien nicht einfach nur Zeile für Zeile importiert werden, sondern beim Import schon auf mehrere Zeilen aufgeteilt werden.
Nicht Spalten, wirklich Zeilen.
Für einen Zeilenumbruch kann die Zeichenkette UNH verwendet werden.
Ergebnis z.B.
Textdatei 1 Zeile 1 bis 5
Textdatei 2 Zeile 6 vis 8
...
Schön wäre, wenn die Trennung vor dem UNH erfolgt.
Wie geht soetwas, bzw. ist dann das obenstehende Makro verwendbar?
Vielen Dank,
Daniel.

Hallo,
liegt wohl an dem Text, der lässt sich in dieser Version in einem Array nicht drehen.
Versuch wir es einfach und drehen dies in einer Schleife.

Sub Makro1()
Dim Datei As String, freeRow As Long, nCount As Long
Dim Qe As Integer, F As Integer
Dim PFAD As String, sInhalt As String
Dim varInhalt, NewArray()

PFAD = IIf(Right$(ThisWorkbook.Path, 1) = "\", ThisWorkbook.Path, ThisWorkbook.Path & "\") 'ACHTUNG: Bachslash am Schluss 
PFAD = PFAD & "TextFiles\"
Datei = Dir(PFAD & "*.txt")

Qe = MsgBox("Zum Import muss die aktuelle Tabelle leer sein," & vbCrLf & _
    "bzw. alle Daten der aktuellen Tabelle: "" " & ActiveSheet.Name & " "" werden gelöscht", _
    vbYesNo + vbCritical, "CSV-Import starten ?")

If Qe = vbNo Then
    MsgBox "CSV-Import abgebrochen"
    Exit Sub
Else
    Cells.Clear
End If

Do While Datei <> ""
    freeRow = Cells(Rows.Count, 1).End(xlUp).Row + 1
    
    F = FreeFile
    Open PFAD & Datei For Binary As #F
    sInhalt = Space$(LOF(F))
    Get #F, , sInhalt
    Close

    sInhalt = Replace(sInhalt, vbCrLf, "") 'Zeilenumbrüche entfernen 
    varInhalt = Split(sInhalt, "UNH") 'Text in Array Slitten 
    Redim Preserve NewArray(1 To Ubound(varInhalt) + 1, 1 To 1)
    
    For nCount = Lbound(varInhalt) To Ubound(varInhalt)
        NewArray(nCount + 1, 1) = varInhalt(nCount)
    Next nCount

    
    Cells(freeRow, 1).Resize(Ubound(NewArray), 1) = NewArray 'in Zelle schreiben 
    Erase NewArray
    Datei = Dir()
Loop

End Sub

Gruß Tino

txt Dateien importieren mit Zeilenumbruch

Forumthread: txt Dateien importieren mit Zeilenumbruch

7
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Forumthreads zu verwandten Themen

Infobox / Tutorial