bestimmten Text aus mehreren Textdateien in Tabell

Sub einlesen() Dim fso As Object Dim fo As Object Dim f As Object Dim lng As Long Dim text1 As String Dim pf$ 'Workbooks.Add pf = BrowseForFolder(0, "Pfad für die Textdateien wählen ..") If pf = vbNullString Then Exit Sub Set fso = CreateObject("Scripting.FileSystemObject") Set fo = fso.GetFolder(pf) For Each f In fo.Files Open f.Path For Input As #1 Do While Not EOF(1) Line Input #1, text1 lng = lng + 1 Cells(lng, 1) = text1 Loop Close #1 Next 'f End Sub

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Hallo,
danke Rainer, mit deinem Code bekomme ich die benötigten Texte in Spalte A
wie bekomme ich nun noch die Texte aus Zeile 2 in Spalte B
und aus Zeile 3 in Spalte C ... bis ende Textdatei, oder bis Zeile 7, dass genügt mir.
Problem: die Bedingungen in den Zeilen der Textdateien sind nicht immer gleich,
in Zeile 2 suche zwischen "X" und "Y", in Zeile 3 suche zwischen "X1" und "Y1", ...
also muss für jede Zeile eine eigene Anfangs und Endbedingung festgelegt werden können.
@Renée
ich hoffe dass aus dieser Beschreibung mein Anliegen deutlicher geworden ist.
Es soll in Spalte A aus Zeile 1 zwischen "X0" und "Y0" aller Textdateien im Ordner A untereinander,
das funktioniert schon.
Nun noch das gleiche mit Zeile 2 zwischen "X" und "Y" in Spalte B, ...
Wenn eine Textdatei länger ist, als 7 Zeilen, dann könnte der gesamte Text aus Zeile 8 in Spalte H
aus Zeile 9 in Spalte I, ...
Wenn das nicht möglich ist, kann auch bei 7 ende sein.
Gregor

Sub einlesen() Dim fso As Object Dim fo As Object Dim f As Object Dim lng As Long Dim pf$ pf = BrowseForFolder(0, "Pfad für die Textdateien wählen ..") If pf = vbNullString Then Exit Sub Set fso = CreateObject("Scripting.FileSystemObject") Set fo = fso.GetFolder(pf) Dim readtext, readtext2, readtext3 As String Dim i, j As Long Close #1 i = 1 j = 1 For Each f In fo.Files If Right(f.Name, 4) = ".txt" Then Open f.Path For Input As #1 Do While Not EOF(1) Line Input #1, readtext If InStr(1, readtext, "") = 0 Or InStr(1, readtext, ">") = Null Then GoTo _ NichtGefunden readtext2 = Right(readtext, Len(readtext) - (InStr(1, readtext, "") - 1) Tabelle5.Cells(i, j) = readtext3 NichtGefunden: j = j + 1 Loop Close #1 i = i + 1 j = 1 End If Next End Sub

Case 3 If InStr(1, readtext, "position") = Null Or InStr(1, readtext, "position") = 0 Or _ InStr(1, readtext, ">") = 0 Or InStr(1, readtext, ">") = Null Then GoTo _ NichtGefunden readtext2 = Right(readtext, Len(readtext) - (InStr(1, readtext, "position") + 9) _ ) readtext3 = Left(readtext2, InStr(1, readtext2, ">") - 2) Tabelle5.Cells(i, j) = readtext3 j = j + 1 If InStr(1, readtext, ">") = Null Or InStr(1, readtext, ">") = 0 Or _ InStr(1, readtext, ""))) readtext3 = Left(readtext2, InStr(1, readtext2, "

Hallo,
Danke Rainer für deine Hilfe.
Ich gebe hier noch meinen kompletten Code an,
damit andere Anwender, die das gleiche Anliegen haben,
diesen für sich nutzen können.


Option Explicit
Private Type BrowseInfo
hwndOwner As Long
pIDLRoot As Long
pszDisplayName As Long
lpszTitle As Long
ulFlags As Long
lpfnCallback As Long
lParam As Long
iImage As Long
End Type
Private Const BIF_RETURNONLYFSDIRS = 1
Private Const MAX_PATH = 1000
Private Declare Sub CoTaskMemFree Lib "ole32.dll" (ByVal hMem As Long)
Private Declare Function lstrcat Lib "kernel32" Alias "lstrcatA" (ByVal lpString1 As String,  _
ByVal lpString2 As String) As Long
Private Declare Function SHBrowseForFolder Lib "shell32" (lpbi As BrowseInfo) As Long
Private Declare Function SHGetPathFromIDList Lib "shell32" (ByVal pidList As Long, ByVal  _
lpBuffer As String) As Long
Sub einlesen()
Dim fso As Object
Dim fo As Object
Dim f As Object
Dim lng As Long
Dim pf$
pf = BrowseForFolder(0, "Pfad für die Textdateien wählen ..")
If pf = vbNullString Then Exit Sub
Set fso = CreateObject("Scripting.FileSystemObject")
Set fo = fso.GetFolder(pf)
Dim readtext, readtext2, readtext3 As String
Dim i, j As Long
Close #1
j = 1
i = 1
For Each f In fo.Files
If Right(f.Name, 4) = ".txt" Then
Open f.Path For Input As #1
j = 1
Do While Not EOF(1)
Line Input #1, readtext
Select Case j
Case 1
If InStr(1, readtext, ""&lt!-- ") = Null Or InStr(1, readtext, ""&lt!-- ") = 0 Or _
InStr(1, readtext, " -->") = 0 Or InStr(1, readtext, " -->") = Null Then GoTo  _
NichtGefunden
readtext2 = Right(readtext, Len(readtext) - (InStr(1, readtext, "&lt!-- ") + 4)) _
readtext3 = Left(readtext2, InStr(1, readtext2, " -->") - 1)
Tabelle5.Cells(i, j) = readtext3
Case 2
If InStr(1, readtext, "id") = Null Or InStr(1, readtext, "id") = 0 Or _
InStr(1, readtext, ">") = 0 Or InStr(1, readtext, ">") = Null Then GoTo  _
NichtGefunden
readtext2 = Right(readtext, Len(readtext) - (InStr(1, readtext, "id") + 3))
readtext3 = Left(readtext2, InStr(1, readtext2, ">") - 2)
Tabelle5.Cells(i, j) = readtext3
Case 3
If InStr(1, readtext, "position") = Null Or InStr(1, readtext, "position") = 0 Or _
InStr(1, readtext, ">") = 0 Or InStr(1, readtext, ">") = Null Then GoTo  _
NichtGefunden
readtext2 = Right(readtext, Len(readtext) - (InStr(1, readtext, "position") + 9) _
)
readtext3 = Left(readtext2, InStr(1, readtext2, ">") - 2)
Tabelle5.Cells(i, j) = readtext3
j = j + 1
If InStr(1, readtext, ">") = Null Or InStr(1, readtext, ">") = 0 Or _
InStr(1, readtext, "")))
readtext3 = Left(readtext2, InStr(1, readtext2, "") = Null Or InStr(1, readtext, ">") = 0 Or _
InStr(1, readtext, "")))
readtext3 = Left(readtext2, InStr(1, readtext2, "") = Null Or InStr(1, readtext, ">") = 0 Or _
InStr(1, readtext, "")))
readtext3 = Left(readtext2, InStr(1, readtext2, "") = Null Or InStr(1, readtext, ">") = 0 Or _
InStr(1, readtext, "")))
readtext3 = Left(readtext2, InStr(1, readtext2, "

Gregor

Beliebteste Forumthreads (12 Monate)

bestimmten Text aus mehreren Textdateien in Tabell

10 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

10
Beiträge zum Forumthread

Beiträge zu diesem Forumthread