AW: mit VBA/VBS Textdateien bearbeiten ?
19.08.2011 15:17:05
Tino
Hallo,
hier noch eine Variante.
Im Code gehe ich mal davon aus das sich die Excel-Datei mit dem Code im Ordner der Textdatei befindet,
wenn dies nicht so ist müsstest Du den Pfad anpassen. (siehe Kommentare)
Am Ende wird in der Tabelle1 noch ausgegeben ob die Zeilen im Text gefunden wurden. (ok. oder Fehler!)
Mach von den Textdateien zuerst eine Sicherung, sollte es mit dem Code nicht gehen ist nichts verloren.
Option Explicit
Sub Beispiel()
Dim F%, CountLen%
Dim strPath$, strDir$, sLines$, varInfo(), sInfo$
Dim ArrayFile()
Dim n&, nn&, nStart&, nLaenge&
Const TeilAbPos$ = "HIER IST DER VORSPANN ZU ENDE"
Const TeilBisPos$ = "HIER BIGINNT DER NACHSPANN"
'evtl. Pfad anpassen wo sich die Textdateien befinden
'hier sind diese auch diese Excel-Datei liegt
strPath = ThisWorkbook.Path
If Right$(strPath, 1) <> "\" Then strPath = strPath & "\"
'*.txt- Dateien im Ordner suchen u. sammeln
strDir = Dir$(strPath & "*.txt", vbNormal)
Do While strDir <> ""
Redim Preserve ArrayFile(n)
ArrayFile(n) = strPath & strDir
n = n + 1
strDir = Dir$()
Loop
If n > 0 Then
CountLen = Len(strPath) + 1
Redim varInfo(1 To n, 1 To 2)
For n = Lbound(ArrayFile) To Ubound(ArrayFile)
sInfo = "Fehler!" 'Fehler ist, Start oder Ende nicht gefunden
'Datei einlesen
F = FreeFile
Open ArrayFile(n) For Binary As #F
sLines = Space$(LOF(F))
Get #F, , sLines
Close
'Text ausschneiden u. zurückschreiben
nStart = InStr(sLines, TeilAbPos)
nLaenge = InStr(sLines, TeilBisPos) - 2
If nStart > 0 And nLaenge > 0 Then
nStart = nStart + Len(TeilAbPos) + 1
nLaenge = nLaenge - nStart
sLines = Trim$(Mid$(sLines, nStart, nLaenge))
Open ArrayFile(n) For Output As #F
Print #F, sLines
Close #F
sInfo = "ok."
End If
'Infos sammeln
varInfo(n + 1, 1) = Mid$(ArrayFile(n), CountLen, Len(ArrayFile(n)))
varInfo(n + 1, 2) = sInfo
sLines = ""
Next n
'Info in einer Tabelle ausgeben
With Tabelle1 'evtl. Tabelle anpassen
.Range("A:B").Delete 'Spalten löschen
.Cells(1, 1) = "Dateiname" 'Überschrift
.Cells(1, 2) = "Info" 'Überschrift
.Rows(1).Font.Bold = True 'Überschrift fett
'Ausgabe in Zelle
.Cells(2, 1).Resize(Ubound(varInfo), Ubound(varInfo, 2)) = varInfo
.Range("A:B").EntireColumn.AutoFit
End With
Else
'Fehler keine Textdatei im Ordner
MsgBox "keine Textdatei gefunden!", vbExclamation
End If
End Sub
Gruß Tino