VBA automatisierte Verarbeitung TXT Dateien

Hallo VBA-Crew,
ich benötige zur Lösung meiner VBA Bearbeitung eure Hilfe und Hoffe ich bin hier richtig.
1.) Mit meinem MAKRO möchte ich eine große Anzahl von Textdateien auswählen und als Array einlesen. Hierzu erfolgt über ein Formular die Auswahl des Ordnerverzeichnis und ggf. die Mehrfachauswahl der betreffenden Textdateien. Leider funktioniert aktuell nur das einlesen und verarbeiten einer Textdatei.
2.) Ist es möglich aus der Ausgangstextdatei nur bestimmter Suchbegriffe auszulesen und in das Array zu Überführen?
Beispiel: Es gibt in der Datei tausende Segmente die mit dem String QTY+79: beginnen dann folgt ein Verbrauchswert und danach kommt ein Hochkomma als Begrenzungskonstante. Ich möchte immer nur den Verbrauchswert ermitteln der zwischen dem Start String und der Begrenzungskonstante steht und diese alle in ein Array überführen.
Ist soetwas überhaupt möglich oder muss ich eine weitere Bearbeitung und Auslesung erst durchführen wenn das Array in ein Excel Arbeitsblatt kopiert wurde?
P.S: unter dem folgenden Link befindet sich die ZIP-Datei mit: der MAKRO Datei, Beispiel Textdatei, Screenshots zur weiteren Erklärung der Problemstellung.
https://www.herber.de/bbs/user/103563.zip
Gruß
Tom

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Option Explicit Sub prepare() Dim objFileSystem Dim strPath Dim strFile Dim strNewFile Dim objFile Dim strContent Dim strSearch Dim strReplace Dim Zeile As Long, Spalte As Long Dim InputData As String strPath = "C:\Daten\automatisierte_Txt_import_Mehrfachauswal\" 'anpassen strFile = "Test.txt" 'anpassen strNewFile = "changedText.txt" 'anpassen strSearch = "QTY+79:" strReplace = "QTY+79:" & Chr(13) & Chr(10) Set objFileSystem = CreateObject("Scripting.FileSystemObject") objFileSystem.CopyFile strPath & strFile, strPath & strNewFile Set objFile = objFileSystem.OpenTextFile(strNewFile, 1) strContent = Replace(objFile.ReadAll, strSearch, strReplace) Set objFile = objFileSystem.OpenTextFile(strNewFile, 2) objFile.Write (strContent) objFile.Close Set objFile = Nothing Set objFileSystem = Nothing 'jetzt in Tabelle schreiben Zeile = 2 Spalte = 1 Open strNewFile For Input As #1 Do Until EOF(1) On Error Resume Next Line Input #1, InputData Sheets("Tabelle1").Cells(Zeile, Spalte) = _ Left(InputData, InStr(1, InputData, "'") - 1) Zeile = Zeile + 1 Loop Close #1 End Sub

Option Explicit Sub prepare() Dim objFileSystem Dim strPath Dim strFile Dim strNewFile Dim objFile Dim strContent Dim strSearch Dim strReplace Dim Zeile As Long, Spalte As Long Dim InputData As String strPath = "C:\Daten\" 'anpassen strFile = "Textdatei_TL_20160211_BSP.txt" 'anpassen strNewFile = strPath & "changedText.txt" 'anpassen strSearch = "QTY+79:" strReplace = "QTY+79:" & Chr(13) & Chr(10) Set objFileSystem = CreateObject("Scripting.FileSystemObject") objFileSystem.CopyFile strPath & strFile, strNewFile Set objFile = objFileSystem.OpenTextFile(strNewFile, 1) strContent = Replace(objFile.ReadAll, strSearch, strReplace) Set objFile = objFileSystem.OpenTextFile(strNewFile, 2) objFile.Write (strContent) objFile.Close Set objFile = Nothing Set objFileSystem = Nothing 'jetzt in Tabelle schreiben Zeile = 2 Spalte = 1 Open strNewFile For Input As #1 Do Until EOF(1) On Error Resume Next Line Input #1, InputData Sheets("Tabelle1").Cells(Zeile, Spalte) = _ Left(InputData, InStr(1, InputData, "'") - 1) Zeile = Zeile + 1 Loop Close #1 End Sub

Sub find_String_copy_partly_to_new_Sheet() Dim Counter As Long Dim zaehler As Long 'Dim Zeile As Long Dim strActiveCell As String Dim Address As String Dim strSearch01 Dim strSearch02 Dim strSearch03 Dim colcount As Long Counter = Worksheets(3).UsedRange.count strActiveCell = ActiveCell.Value Address = ActiveCell.Address strSearch01 = "QTY+79:" strSearch02 = "LOC+172+:" strSearch03 = "LIN+1'PIA+5+1-1?" Worksheets(3).Range("c:c").Activate colcount = 3 zaehler = 1 For zaehler = 1 To Counter ' Hier soll mit der Leftfunktion ein Abgleich der ersten 7 Stringzeichen durchgeführt werden. ' stimmen diese mit dem String aus der variablen strSearch01 = "QTY+79:" überein soll mit der 'Mid-Funktion nur der letze String Teil der Zelle in ein anderes arbeitsblatt kopiert werden If Worksheets(3).Cells(zaehler, colcount).Value = Left(ActiveCell.Value, 7) = strSearch01 _ Then ActiveCell.Mid(ActiveCell.Value, 7, 4).Copy Destination:=Worksheets("Daten_Import").Range(" _ C1").Offset(1, 0) zaehler = zaehler + 1 Else zaehler = zaehler + 1 End If Next zaehler End Sub

Hallo Tom,
ich bleibe bei meinem Ansatz: Mit kopieren und geringen Änderungen war er leicht anzupassen:

Option Explicit
Sub prepare()
Dim objFileSystem
Dim strPath
Dim strFile
Dim strNewFile
Dim objFile
Dim strContent
Dim strSearch01
Dim strReplace01
Dim strSearch02
Dim strReplace02
Dim strSearch03
Dim strReplace03
Dim Zeile As Long, Spalte As Long
Dim InputData As String
strPath = "C:\Temp\" 'anpassen
strFile = "Textdatei_TL_20160211_BSP.txt" 'anpassen
strNewFile = strPath & "changedText1.txt" 'anpassen
strSearch01 = "QTY+79:"
strReplace01 = "QTY+79:" & Chr(13) & Chr(10)
strSearch02 = "LOC+172+"
strReplace02 = "LOC+172+" & Chr(13) & Chr(10)
strSearch03 = "LIN+1'PIA+5+1-1?:"
strReplace03 = "LIN+1'PIA+5+1-1?;" & Chr(13) & Chr(10)
'Suchen und Ersetzen zum Ersten:
'temporäre Datei aus der Originaldatei erstellen
'Suchen und ersetzen mit strSearch01 und strReplace01 durchführen
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
objFileSystem.CopyFile strPath & strFile, strNewFile
Set objFile = objFileSystem.OpenTextFile(strNewFile, 1)
strContent = Replace(objFile.ReadAll, strSearch01, strReplace01)
Set objFile = objFileSystem.OpenTextFile(strNewFile, 2)
objFile.Write (strContent)
objFile.Close
Set objFile = Nothing
Set objFileSystem = Nothing
'Suchen und Ersetzen zum Zweiten:
'temporäre Datei aus der ersten temporären Datei erstellen
'Suchen und ersetzen mit strSearch02 und strReplace02 durchführen
strFile = strPath & "changedText1.txt" 'anpassen
strNewFile = strPath & "changedText2.txt" 'anpassen
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
objFileSystem.CopyFile strFile, strNewFile
Set objFile = objFileSystem.OpenTextFile(strNewFile, 1)
strContent = Replace(objFile.ReadAll, strSearch02, strReplace02)
Set objFile = objFileSystem.OpenTextFile(strNewFile, 2)
objFile.Write (strContent)
objFile.Close
Set objFile = Nothing
Set objFileSystem = Nothing
'Suchen und Ersetzen zum Dritten:
'temporäre Datei aus der zweiten temporären Datei erstellen
'Suchen und ersetzen mit strSearch03 und strReplace03 durchführen
strFile = strPath & "changedText2.txt" 'anpassen
strNewFile = strPath & "changedText3.txt" 'anpassen
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
objFileSystem.CopyFile strFile, strNewFile
Set objFile = objFileSystem.OpenTextFile(strNewFile, 1)
strContent = Replace(objFile.ReadAll, strSearch03, strReplace03)
Set objFile = objFileSystem.OpenTextFile(strNewFile, 2)
objFile.Write (strContent)
objFile.Close
Set objFile = Nothing
Set objFileSystem = Nothing
'jetzt die gesuchten Daten in Tabelle schreiben
Zeile = 2
Spalte = 1
Open strNewFile For Input As #1
Do Until EOF(1)
On Error Resume Next
Line Input #1, InputData
If Left(InputData, 2) = "::" Then GoTo sprung
Sheets("Tabelle1").Cells(Zeile, Spalte) = _
Replace(Left(InputData, InStr(1, InputData, "'") - 1), ":SRW", "")
Zeile = Zeile + 1
sprung:
Loop
Close #1
'Schließlich die überflüssigen temporären "changedText-Dateien" löschen
Dim fileNumber As Integer
Set objFileSystem = CreateObject("Scripting.FileSystemObject")
For fileNumber = 1 To 3
objFileSystem.DeleteFile strPath & "changedText" & fileNumber & ".txt"
Next
Set objFileSystem = Nothing
End Sub

Gruß
Jochen

Option Explicit Sub ordnen() Dim sp As Long Dim zeile As Long Dim ze As Object Dim shSource As Worksheet Dim shDest As Worksheet Set shSource = ThisWorkbook.Sheets("Temp_Verlauf") Set shDest = ThisWorkbook.Sheets("Werte") sp = 1 zeile = 2 With shSource For Each ze In .Range("A2:A" & .Cells(Rows.Count, 1).End(xlUp).Row) If Not IsNumeric(ze) And InStr(1, ze, ".") = 0 Then shDest.Cells(1, sp) = .Cells(ze.Row, 1) sp = sp + 1 zeile = 2 Else shDest.Cells(zeile, sp - 1) = .Cells(ze.Row, 1) zeile = zeile + 1 End If Next End With End Sub

Sub prepare() Dim objFileSystem Dim strPath Dim strFile Dim strNewFile Dim objFile Dim strContent Dim strSearch Dim strSearch02 As String Dim strSearch03 As String Dim strReplace Dim strReplace02 Dim strReplace03 Dim Zeile As Long, Spalte As Long Dim InputData As String strPath = "C:\Daten\" 'anpassen strFile = "Testdatei01.txt" 'anpassen strNewFile = "temp_" & strFile & ".txt" 'anpassen strSearch = "QTY+79:" strReplace = "QTY+79:" & Chr(13) & Chr(10) strSearch02 = "LOC+172+:" strReplace02 = "LOC+172+:" & Chr(13) & Chr(10) strSearch03 = "LIN+1'PIA+5+1-1?" & ":SRW" strReplace03 = "LIN+1'PIA+5+1-1?" & Chr(13) & & ":SRW" & Chr(10) Set objFileSystem = CreateObject("Scripting.FileSystemObject") objFileSystem.CopyFile strPath & strFile, strPath & strNewFile Set objFile = objFileSystem.OpenTextFile(strPath & strNewFile, 1) strContent = Replace(objFile.ReadAll, strSearch,strSearch02,strSearch03, _ strReplace, strReplace02,strReplace03) Set objFile = objFileSystem.OpenTextFile(strPath & strNewFile, 2) objFile.Write (strContent) objFile.Close Set objFile = Nothing Set objFileSystem = Nothing 'jetzt in Tabelle schreiben Zeile = 2 Spalte = 3 Open strPath & strNewFile For Input As #1 Do Until EOF(1) On Error Resume Next Line Input #1, InputData Worksheets(3).Cells(Zeile, Spalte) = _ Left(InputData, InStr(1, InputData, "'") - 1) Zeile = Zeile + 1 Loop Close #1 End Sub

Beliebteste Forumthreads (12 Monate)

VBA automatisierte Verarbeitung TXT Dateien

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

VBA automatisierte Verarbeitung TXT Dateien

11 Beiträge zum Forumthread Beiträge zu diesem Forumthread

309 Forumthreads zu ähnlichen Themen

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

11
Beiträge zum Forumthread

Beiträge zu diesem Forumthread