Inhalt von Word-Dateien in Excel anzeigen

Question

Hallo,

ich suche für folgendes Problem eine Lösung:

Ich habe einen Ordner mit mehr als 2000 Dateien im .rtf bzw. .txt Format.
Nun möchte ich aber in Excel eine Übersicht über den Inhalt, bzw. eine
Auflistung des Inhalts der einzelnen Word-Dateien (meist nur 1 - 2 Sätze
je Datei).

Ich habe nun (dank Internet) schonmal eine Lösung, so dass mir in
Spalte A der gesamte Inhalt des Ordners angezeigt werden (nur rtf-
Dateien). Wie aber nun in Spalte B den Inhalt der Dateien anzeigen??

Geht das überhaupt oder ist die Tabelle zu groß, es sind ca. 1800 rtf-
Dateien)


Gruss Petra

(Ich nutze übrigens Excel 2010)



Mein Code sieht folgendermaßen aus:

Sub dateinameneinlesen1()
Dim strPfad As String, strDatnam As String
Dim rngEinfüg As Range
Dim ACon As Object
Dim strTemp As String

'Erst der Pfad
strPfad = "D:\Documents\Textbausteine\"
strDatnam = Dir(strPfad & "*.rtf")

Set ACon = CreateObject("ADODB.Stream")

Do While Len(strDatnam)

'Einfügezelle festlegen
Set rngEinfüg = IIf(IsEmpty([A1]), [A1], Cells(Rows.Count,
1).End(xlUp).Offset(1, 0))
rngEinfüg.Offset(, 0) = strTemp

'Dateiname eintragen:
rngEinfüg.Offset(, 0) = strDatnam
strDatnam = Dir

Loop

Set rngEinfüg = Nothing
Set ACon = Nothing

End Sub

Answer 1

Hallo Petra,

versuch es mal so:

Sub rtf_einlesen()

Dim strPfad As String
Dim strDatnam As String
Dim rngEinfüg As Range
Dim wdApp As Object
Dim wdDoc As Object
Dim sFile As String


'Erst der Pfad
strPfad = "D:\Documents\Textbausteine\"
strDatnam = Dir(strPfad & "*.rtf")

Do While Len(strDatnam)

'Einfügezelle festlegen
Set rngEinfüg = IIf(IsEmpty(Cells(1, 1)), Cells(1, 1), Cells(Rows.Count, 1).End(xlUp).Offset(1, 0))
'Dateiname eintragen:
rngEinfüg = strDatnam
sFile = strPfad & strDatnam 'Pfad für das Einlesen der rtf-Dateien
strDatnam = Dir

'hier nun Einlesen der Dateien
'gefunden bei http://www.ms-office-forum.net/forum/showthread.php?t=145277
If Dir(sFile) <> "" Then
Set wdApp = CreateObject("Word.Application")
wdApp.Visible = False
Set wdDoc = wdApp.Documents.Open(sFile)
wdApp.Selection.WholeStory
wdApp.Selection.Copy
wdApp.Quit
Set wdDoc = Nothing
Set wdApp = Nothing
Cells(rngEinfüg.Row, rngEinfüg.Column + 1).Select 'Spalte B wird ausgewählt
ActiveSheet.Paste 'kopierte Daten werden eingefügt
End If

Loop

Set rngEinfüg = Nothing

End Sub

Gruß

M.O.