Thema: txt Inhalt in Excel sortieren | Herbers Excel-Forum

Hallo,
in meinem Ordner Auftrag liegen mehrere txt Dateien. Hier ein exemplarischer Aufbau:
10020041012
105FABRIK 1
106Musterstr.
11112
11370173
187STUTTGART
999
Von diesen Dateien hab ich ca. 200 Stück.
Ich möchte diese Dateien jetzt in ein xls Dokument importieren.
Und zwar sollen die ersten 3 Zeichen einer Zeile in der txt die Spaltenüberschrift sein. Was danach folgt kommt unter die Überschrift. Und so Zeile für Zeile.
Ist eine Textdatei fertig so wird die nächste txt Datei in die Struktur eingebunden.
Bezogen auf mein Beispiel würde die xls dann so aussehen:
100 | 105 | 106 | 111 | 113 | 187
------------------------------------------------------------------------------------
20041012 | Fabrik1 | Musterstr. | 12 | 70173 | Stutgart
Und die nächste Zeile wird aus der nächsten txt befüllt.
Das Problem ist das die Spaltenüberschriften nicht in jeder Datei gleich oft vorkommen.
Es kann z.B. sein das in der nächsten txt die Überschrift 211 enthalten ist.
Jemand eine Idee?

Guten Morgen,
anbei mal ein Beispiel (ungetestet), was Du anpassen must.

Sub Text_Import_alle()
Dim i As Integer
Dim Zeile As Integer
Dim startflag As Boolean
Dim endeflag  As Boolean
Dim pfadfile As String
Dim fileart As String
'StartVerzeichnis - bitte anpassen
ChDrive "c:\"
ChDir "\temp"
pfadfile = "c:\temp\"
fileart = "*.txt"
'Start der Verarbeitung
Zeile = 2
fn = Dir(pfadfile & fileart)
Do While fn <> ""
Open fn For Input As #1
'Cells(Zeile, 1).Value = fn   ' Dateiname
spalte = 1
Do While Not EOF(1)
spalte = 1
Line Input #1, strTxt
'richtige spalte bestimmen
skey = False
lSpalte = Cells(1, 256).End(xlToLeft).Column
For x = 1 To lSpalte
If Cells(1, x).Value = Left(strTxt, 3) Then
spalte = x
skey = True
Exit For
End If
Next x
If Not skey Then
Cells(1, lSpalte + 1).Value = Left(strTxt, 3)
spalte = lSpalte + 1
End If
Cells(Zeile, spalte).Value = Mid(strTxt, 4)
'        Zeile = Zeile + 1
Loop
Close
Zeile = Zeile + 1
fn = Dir()
Loop
End Sub

Gruss
Rückantwort wäre super

hier mal als Beispielmappe mit einer kleinen Änderung
gruss
funkt?
https://www.herber.de/bbs/user/66472.xls

Hi,
hat nicht ganz geklappt Ede
vereinzelt hat das Makro das richtige gemacht
anbei 2 bsp.txt
Danke

-

siehe die Lösung von Rudi,
da gehts auch super mit.
gruss

Hallo,
teste mal:

Sub TextImport()
Dim lngZeile As Long
Dim vntSpalte
Dim strText As String
Dim strFile As String
'anpassen
Const strPfad As String = "c:\test\test\"
Const strArt As String = "*.txt"
Application.ScreenUpdating = False
lngZeile = 2
strFile = Dir(strPfad & strArt)
Do While strFile <> ""
Open strPfad & strFile For Input As #1
Do While Not EOF(1)
Line Input #1, strText
vntSpalte = Application.Match(--Left(strText, 3), Rows(1), 0)
If IsError(vntSpalte) Then
vntSpalte = _
Cells(1, Columns.Count).End(xlToLeft).Column - (Application.CountA(Rows(1)) <> 0)
Cells(1, vntSpalte) = --Left(strText, 3)
End If
Cells(lngZeile, vntSpalte).Value = Mid(strText, 4)
Loop
Close #1
lngZeile = lngZeile + 1
strFile = Dir()
Loop
'nach Überschrift sortieren
Range("A1").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight
Application.ScreenUpdating = True
End Sub

Gruß
Rudi

Hir die bsp.datei
https://www.herber.de/bbs/user/66474.zip

Hallo,

Sub TextImport()
Dim lngZeile As Long
Dim vntSpalte
Dim strText As String
Dim strFile As String
Dim arrText, strTmp
'anpassen
Const strPfad As String = "c:\test\test\"
Const strArt As String = "*.txt"
Application.ScreenUpdating = False
lngZeile = 2
strFile = Dir(strPfad & strArt)
Do While strFile <> ""
Open strPfad & strFile For Input As #1
Do While Not EOF(1)
Line Input #1, strText
arrText = Split(strText, vbLf)
For Each strTmp In arrText
If strTmp <> "" Then
vntSpalte = Application.Match(--Left(strTmp, 3), Rows(1), 0)
If IsError(vntSpalte) Then
vntSpalte = _
Cells(1, Columns.Count).End(xlToLeft).Column - _
(Application.CountA(Rows(1)) <> 0)
Cells(1, vntSpalte) = --Left(strTmp, 3)
End If
Cells(lngZeile, vntSpalte).Value = Mid(strTmp, 4)
End If
Next
Loop
Close #1
lngZeile = lngZeile + 1
strFile = Dir()
Loop
'nach Überschrift sortieren
Range("A1").Sort Key1:=Range("A1"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlLeftToRight
Application.ScreenUpdating = True
End Sub

Gruß
Rudi

einfach nur geinal DANKE!