Viele Text Dateien durchsuchen

Beiträge zum Forumthread

Beiträge zu diesem Forumthread

Betreff

Datum

Anwender

Also, falls je Zeile nur 1x dann so


Sub Zählen_Worte()
Dim Pfad As String, Datei As String, Ext As String
Dim Suchwort As String, Anz As Integer
Dim TB As Worksheet, Sp As Integer, LR As Integer
'**** anpassen
Ext = "*.qd"
Pfad = "E:\Excel\Temp\TT\" '**** mit \
Suchwort = "BESTUECKEN"
Set TB = ThisWorkbook.Sheets("Tabelle1")
Sp = 1 ' Spalte
'**** anpassen Ende
Application.ScreenUpdating = False
'Alle Dateien finden
Datei = Dir(Pfad & Ext)
Do While Len(Datei) > 0
'Datei öffnen
Workbooks.OpenText Filename:=Pfad & Datei, _
Origin:=xlMSDOS, StartRow:=1, DataType:=xlDelimited, _
TextQualifier:=xlDoubleQuote, ConsecutiveDelimiter:=False, _
Tab:=False, Semicolon:=False, Comma:=False, Space:=False, _
Other:=False, FieldInfo:=Array(1, 2), TrailingMinusNumbers:=True
'Zählen
Anz = WorksheetFunction.CountIf(ActiveSheet.Columns(1), "*" & Suchwort & "*")
'Freie Zeile
LR = TB.Cells(TB.Rows.Count, Sp).End(xlUp).Row + 1
'Daten schreiben
TB.Cells(LR, 1) = Datei
TB.Cells(LR, 2) = Anz
'Schliessen ohne Speichern
Workbooks(Datei).Close False
Datei = Dir() ' nächste Datei
Loop
End Sub

LG UweD

Sub test() Dim datei As String Dim pfad As String Dim txt As String Dim Suchwort As String Dim Anzahl As Long pfad = "C:\Daten\Sonstiges\" datei = Dir(pfad & "*.qd") Suchwort = "BESTUECKEN" Do While datei "" txt = ReadFile(pfad & datei) Anzahl = (Len(txt) - Len(Replace(txt, Suchwort, ""))) / Len(Suchwort) Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 2).Value = Array(datei, Anzahl) datei = Dir Loop End Sub Public Function ReadFile(ByVal sFilename As String) As String '--- Quelle: https://www.vbarchiv.net/tipps/tipp_298-textdateien-schnell-auslesen.html Dim F As Integer Dim sInhalt As String F = FreeFile: Open sFilename For Binary As #F sInhalt = Space$(LOF(F)) Get #F, , sInhalt Close #F End If ReadFile = sInhalt End Function

Code: [Cc] Sub Test() Dim iFF As Integer, sFilename As String, sArr() As String Const csPath = "C:\Daten\" sFilename = Dir$(csPath & "*.qd") Do While sFilename <> "" iFF = FreeFile Open csPath & sFilename For Input As iFF ' Datei öffnen sArr = Split(Input(LOF(iFF), iFF), "BESTUECKEN") ' in Array und splitten Close iFF Cells(Rows.Count, 1).End(xlUp).Offset(1, 0).Resize(1, 2).Value _ = Array(sFilename, UBound(sArr)) sFilename = Dir$ Loop End Sub

Beliebteste Forumthreads (12 Monate)

6 Beiträge zum Forumthread Beiträge zu diesem Forumthread

VBA Beispiele zu verwandten Themen

Beliebteste Forumthreads (12 Monate)

Beliebteste Forumthreads (12 Monate)

6
Beiträge zum Forumthread

Beiträge zu diesem Forumthread