Live-Forum - Die aktuellen Beiträge
Datum
Titel
28.03.2024 21:12:36
28.03.2024 18:31:49
Anzeige
Archiv - Navigation
1792to1796
Aktuelles Verzeichnis
Verzeichnis Index
Übersicht Verzeichnisse
Vorheriger Thread
Rückwärts Blättern
Nächster Thread
Vorwärts blättern
Anzeige
HERBERS
Excel-Forum (Archiv)
20+ Jahre Excel-Kompetenz: Von Anwendern, für Anwender
Word Dateien durchsuchen
24.11.2020 07:34:58
stef26
Guten Morgen liebe Excelprofis,
ich habe ein kleines Problem, bei dem ich mit meinen bescheidenen VBA Kenntnissen nicht mehr weiter komme und auf eure Unterstützung hoffe.
Ich habe im Netz ein Makro gefunden, welches ich etwas für meinen Bedarf angepasst habe.
Sub M_snb()
On Error GoTo XL90:
c00 = "C:\Users\xxx\Desktop\Word\"
c01 = Dir(c00 & "*.docx")
sn = Array(ActiveWorkbook.ActiveSheet.Range("C1"), ActiveWorkbook.ActiveSheet.Range("E1"),  _
ActiveWorkbook.ActiveSheet.Range("G1"))
Do Until c01 = ""
With GetObject(c00 & c01)
x = InStr(.Content, sn(0))
y = InStr(.Content, sn(1))
Z = InStr(.Content, sn(2))
.Close -1
End With
c02 = c02 & "|" & c01 & "_" & sn(0) & ": " & x & "  " & sn(1) & ": " & y & "  " & sn(2) &  _
": " & Z
c01 = Dir
Loop
XL90:
st = Split(c02, "|")
Cells(1).Resize(UBound(st)) = Application.Transpose(st)
End Sub
Dieses Makro sucht mir in einen Ordner alle Word Dokumente, die die Suchbegriffe in den Zellen C1,E1,G1 enthalten.
Nun zu meiner Frage:
Gibt es die Möglichkeit, dass ich nicht ausgegeben bekomme wo sich das Word befindet, sondern den ganzen Inhalt der Zeile mir zurück geben lassen kann?
Z.B. Suchbegriff: Auto
Zurückschreiben soll er dann die Ganze Zeile in der das Wort Auto vorkommt.
Das Auto ist grün.
Wer kennt sich in VBA so gut aus um mir zeigen zu können, wie ich das hin bekomme?
Liebe Grüße
Stefan

12
Beiträge zum Forumthread
Beiträge zu diesem Forumthread

Betreff
Datum
Anwender
Anzeige
AW: Word Dateien durchsuchen
24.11.2020 07:54:56
stef26
Hallo nochmal,
ich habe gerade im Netz für meine Aufgabe ein noch geeigneteres Makro gefunden.
Problem hierbei ist, dass die Zeile die aus Word zurückgegeben wird immer die erste Zeile des Word Dokumentes ist, und nicht die Zeile, in der der Suchbegriff gefunden wurde.
Zudem fehlt mir die Angabe in welcher Word Datei der Suchbegriff gefunden wurde.
Sub SuchenZeile()
Dim objWD       As Object
Dim ordner      As String
Dim dot         As String
Dim objDot      As Object
Dim BrowseDir   As Variant
Dim AppShell    As Object
Dim strSuche    As String
Dim strcon      As String
Dim rngclear    As Range
Dim objRange As Object
Dim objFile As Object
Set rngclear = Range("A3:a1000")
rngclear.ClearContents
Set objWD = CreateObject("Word.Application")
Set AppShell = CreateObject("Shell.Application")
Set BrowseDir = AppShell.BrowseForFolder(0, "Ordner auswählen", &H1000, 17)
On Error Resume Next
ordner = BrowseDir.items().Item().Path & "\"
strSuche = InputBox("Bitte Suchbegriff eingeben!", "W")
dot = Dir(ordner & "*.docx", vbNormal)
Do While dot  ""
Set objDot = objWD.Documents.Open(ordner & dot)
With objDot
.ActiveWindow.View.ShowFieldCodes = False
With .Range(0, .Range.End).Find
.Text = strSuche
.Forward = True
If .Execute = True Then
Set objRange = objWD.Selection.Bookmarks("\Line").Range
Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = docx & " " &  _
objRange.Text
End If
'Range("a1").End(xlUp).Offset(1, 0).Value = dot & objRange.Text
End With
.Close False
End With
dot = Dir
Loop
objWD.Quit
MsgBox "Done with conditional statements!"
End Sub

Wer könnte mir beide Makros so verheiraten, dass die richtige Zeile ausgegeben wird und der Dateiname mit angegeben wird?
Liebe Grüße
Stefan
Anzeige
AW: link zur ursprünglichen Frage
24.11.2020 10:36:50
Fennek
Hallo Stefan,
die Frage beschäftigt Dich schon seit Tagen/Wochen in mehreren Fragen: Könntest Du die ursprüngliche Frage noch einmal verlinken?
Aus den gezeigten Codes auf das Problem zu schließen, ist zwar möglich, aber unnötig.
Wurde die Frage in CEF gestellt?
mfg
AW: link zur ursprünglichen Frage
24.11.2020 11:15:40
stef26
Hallo Fennek,
ich kann leider auf meine Beiträge nicht mehr zugreifen.
Dieses Thema ist jedoch neu.
Mit dem vorherigen Thema hab ich aus verschiedenen Excellisten Zellen ausgelesen, was ich dann irgendwann mal selber hin bekommen habe.
Bei diesem Thema was ähnlich ist, sollen viele Word Dateien durchsucht werden.
Ist das Wort gefunden, soll die ganze Zeile des Wortes zurückgegeben werden.
Was ist CEF?
Gruß
Stefan
Anzeige
AW: link zur ursprünglichen Frage
24.11.2020 17:13:09
Matthias
Moin!
ICh habe mal den Code von SNB ein wenig angepasst und erweitert. Insb. ein paar aussagekräftigere Namen verwendet. :-) Die Datei wird wie bei ihm geöffnet und der Inhalt ausgelesen. Den splitte ich dann nach dem Zeilenumbruch und schaue dann nach deinen Kriterien. Dies suche sollte auch mehrere Treffer finden und jeweils mit Zeilennummer und Text ausgeben. Die ausgelesenen Werte werden dabei in ein Array eingelesen und am Ende in einen Bereich ab A2 eingetragen. Der Bereich sollte 4 Spalten breit sein (sonst werden DAten überschrieben).
SChaue mal, ob das so passt.
Sub M_snb()
Dim inhalt As Variant
Dim pfad, datnamem, kriterien(1 To 3)
Dim treffer()
Dim temp
Dim zeile As Long, anzdat As Long, krit As Long
On Error GoTo XL90:
pfad = ActiveWorkbook.Path & "\"
datname = Dir(pfad & "*.docx")
ReDim Preserve treffer(1 To 4, 1 To 2)
treffer(1, 1) = "Trefferübersicht"
kriterien(1) = ActiveWorkbook.ActiveSheet.Range("C1")
kriterien(2) = ActiveWorkbook.ActiveSheet.Range("E1")
kriterien(3) = ActiveWorkbook.ActiveSheet.Range("G1")
treffer(1, 2) = "Dateiname"
treffer(2, 2) = kriterien(1)
treffer(3, 2) = kriterien(2)
treffer(4, 2) = kriterien(3)
anzdat = 0
Do Until datname = ""
With GetObject(pfad & datname)
inhalt = .Content
.Close -1
End With
'Inhalt nach Zeilen aufsplitten
temp = Split(inhalt, Chr(13))
anzdat = anzdat + 1
ReDim Preserve treffer(1 To 4, 1 To anzdat + 2)
treffer(1, anzdat + 2) = datname
For krit = 1 To 3
If InStr(1, inhalt, kriterien(krit), vbTextCompare) > 0 Then
For zeile = 0 To UBound(temp)
If InStr(1, temp(zeile), kriterien(krit), vbTextCompare) > 0 Then
treffer(krit + 1, anzdat + 2) = treffer(krit + 1, anzdat + 2) & vbCrLf & " _
Zeile: " & zeile + 1 & " : " & temp(zeile)
End If
Next
Else
treffer(krit + 1, anzdat + 2) = "kein Treffer"
End If
Next
datname = Dir
Loop
XL90:
Cells(2, 1).Resize(UBound(treffer, 2), 4) = Application.Transpose(treffer)
End Sub
Achja, das CEF ist das Clever Excel Forum. Da SNB meist hier nicht postet, stand die Vermutung im Raum.
Anzeige
AW: link zur ursprünglichen Frage
24.11.2020 19:13:36
stef26
Hallo Matthias,
Ich habe das Programm mal über 300 Doc-Dateien laufen lassen.
Hat über ne 1/2 Stunde gearbeitet bis das Ergebnis kam...
Das ist ja echt geil geworden.
Recht herzlichen Dank für deine Unterstützung!!!
So klasse.
Mein Tag ist gerettet...
DANKE
Stefan
P.S. Sehr cooles Forum
AW: link zur ursprünglichen Frage
24.11.2020 20:51:50
stef26
Hallo Matthias,
ich hätte doch noch eine kleine Frage zum Code.
XL90:
Cells(2, 1).Resize(UBound(treffer, 2), 4) = Application.Transpose(treffer)
Bei Fehler geht das Programm auf diese Zeile.
Was könnte so ein Grund sein?
Habe festgestellt, dass bei bestimmten Suchbegriffen das Programm mit dem Fehler:
Typen unverträglich Laufzeitfehler 13:
Ist dass, weil der Begriff zu oft im Dok vorkommt, oder an was könnte dies liegen?
Gruß
Stefan
Anzeige
AW: link zur ursprünglichen Frage
24.11.2020 21:09:11
stef26
Hallo Matthias,
ich hab den Fehler anhand einer Beispiel Doc nachvollziehen können.
Wird ein Suchbegriff mehr als 8x gefunden, dann geht der Code auf Fehler.
Kann man das irgendwie noch ändern, oder ist das nicht änderbar?
Gruß
Stefan
AW: link zur ursprünglichen Frage
25.11.2020 09:09:15
Matthias
Moin!
Natürlich kann man alles ändern / beheben - wird aber erst heute Abend. :-) In diesem Fall liegt es nicht direkt an der Anzahl des Suchbegriffs, sondern an der Funktion Transpose. Die hat so einige "Unzulänglichkeiten". Bei zuviel Daten haut sie den Fehler raus. Wenn du nur das Array Treffer einträgst, ist der Fehler weg aber auch die richtige Formatierung (Zeilen, Spalten). Hatte es so wie im Code in das Array eingelesen, da man damit einfacher "Zeilen" hinzufügen kann. Die Anführungszeichen deshalb, da im COde Spalten hinzugefügt werden und dann mit Transpose zu Zeilen werden.
Um den Fehler zu beheben, würde ich den Transpose mit zwei Schleifen einfach selber gestalten. Dann sollte es hinhauen. Wird aber wie gesagt erst heute Abend.
VG
Anzeige
AW: link zur ursprünglichen Frage
25.11.2020 10:12:05
stef26
Hallo Matthias,
das ist voll lieb von dir.
Ich hab zwar nicht alles verstanden, da mein VBA in den Kinderschuhen steckt, aber wenn das irgendwie mit einer zusätzlichen Schleife funktionieren sollte wäre das super.
Danke für deine Unterstützung.
Gruß
Stefan
AW: link zur ursprünglichen Frage
25.11.2020 10:32:05
stef26
Moin Main nochmal,
falls es leichter sein sollte die Ergebnisse nicht in eine Zelle zu schreiben, sondern für jedes gefundene Zeile eine extra Zelle dann wäre das auch gut. Wäre dann bei der Auswertung etwas einfacher zu handhaben. Aber nur wenn es vom Aufwand kein Unterschied für dich wäre...
Liebe Grüße
Stefan
Anzeige
AW: link zur ursprünglichen Frage
25.11.2020 21:36:02
Matthias
Moin!
Wie versprochen hier die Versionen.
1. Variante (alles in einer Zelle):
Sub M_snb()
Dim inhalt As Variant
Dim pfad, datnamem, kriterien(1 To 3)
Dim treffer(), fertig()
Dim temp
Dim zeile As Long, anzdat As Long, krit As Long, spalte As Long
On Error GoTo XL90:
pfad = ActiveWorkbook.Path & "\"
datname = Dir(pfad & "*.docx")
ReDim Preserve treffer(1 To 4, 1 To 2)
treffer(1, 1) = "Trefferübersicht"
kriterien(1) = ActiveWorkbook.ActiveSheet.Range("C1")
kriterien(2) = ActiveWorkbook.ActiveSheet.Range("E1")
kriterien(3) = ActiveWorkbook.ActiveSheet.Range("G1")
treffer(1, 2) = "Dateiname"
treffer(2, 2) = kriterien(1)
treffer(3, 2) = kriterien(2)
treffer(4, 2) = kriterien(3)
anzdat = 0
Do Until datname = ""
With GetObject(pfad & datname)
inhalt = .Content
.Close -1
End With
'Inhalt nach Zeilen aufsplitten
temp = Split(inhalt, Chr(13))
anzdat = anzdat + 1
ReDim Preserve treffer(1 To 4, 1 To anzdat + 2)
treffer(1, anzdat + 2) = datname
For krit = 1 To 3
If kriterien(krit)  "" Then
If InStr(1, inhalt, kriterien(krit), vbTextCompare) > 0 Then
For zeile = 0 To UBound(temp)
If InStr(1, temp(zeile), kriterien(krit), vbTextCompare) > 0 Then
treffer(krit + 1, anzdat + 2) = treffer(krit + 1, anzdat + 2) & vbCrLf & _
"     Zeile: " & zeile + 1 & " : " & temp(zeile)
End If
Next
Else
treffer(krit + 1, anzdat + 2) = "kein Treffer"
End If
End If
Next
datname = Dir
Loop
XL90:
ReDim fertig(1 To UBound(treffer, 2), 1 To 4)
For zeile = 1 To 4
For spalte = 1 To UBound(treffer, 2)
fertig(spalte, zeile) = treffer(zeile, spalte)
Next spalte
Next zeile
Cells(2, 1).Resize(UBound(treffer, 2), 4) = fertig
End Sub

2. Variante (jeder Eintrag eine Zeile - sollte zumindest so sein :-) )
Sub M_snb()
Dim inhalt As Variant
Dim pfad, datnamem, kriterien(1 To 3)
Dim treffer(), fertig()
Dim temp
Dim zeile As Long, anzzeil As Long, krit As Long, spalte As Long
Dim startp As Long, endp As Long, nextp As Long
Dim erster As Boolean
On Error GoTo fehler
pfad = ActiveWorkbook.Path & "\"
datname = Dir(pfad & "*.docx")
ReDim Preserve treffer(1 To 4, 1 To 2)
treffer(1, 1) = "Trefferübersicht"
kriterien(1) = ActiveWorkbook.ActiveSheet.Range("C1")
kriterien(2) = ActiveWorkbook.ActiveSheet.Range("E1")
kriterien(3) = ActiveWorkbook.ActiveSheet.Range("G1")
treffer(1, 2) = "Dateiname"
treffer(2, 2) = kriterien(1)
treffer(3, 2) = kriterien(2)
treffer(4, 2) = kriterien(3)
anzzeil = 2
erster = True
Do Until datname = ""
With GetObject(pfad & datname)
inhalt = .Content
.Close -1
End With
'Inhalt nach Zeilen aufsplitten
temp = Split(inhalt, Chr(13))
anzzeil = anzzeil + 1
startp = anzzeil
endp = startp
ReDim Preserve treffer(1 To 4, 1 To anzzeil)
treffer(1, anzzeil) = datname
For krit = 1 To 3
If kriterien(krit)  "" Then
If InStr(1, inhalt, kriterien(krit), vbTextCompare) > 0 Then
nextp = startp
For zeile = 0 To UBound(temp)
If InStr(1, temp(zeile), kriterien(krit), vbTextCompare) > 0 Then
If nextp  endp Then endp = nextp - 1
Else
treffer(krit + 1, startp) = "kein Treffer"
End If
End If
Next
datname = Dir
Loop
ReDim fertig(1 To UBound(treffer, 2), 1 To 4)
For zeile = 1 To 4
For spalte = 1 To UBound(treffer, 2)
fertig(spalte, zeile) = treffer(zeile, spalte)
Next spalte
Next zeile
Cells(2, 1).Resize(UBound(treffer, 2), 4) = fertig
MsgBox "Fertig"
Exit Sub
fehler:
MsgBox "Irgendwas ist schief gelaufen!"
End Sub
Die zweite Variante bitte mal testen.
Ggf. könnte man an der laufzeit noch was ändern. Bspw. erstellt die getobject immer eine Instanz von word und scließt die wieder. Da könnte es ggf. kürzer sein, Word offen zu lassen und nur die Dateien zu öffnen. Ist aber nur eine Theorie.
VG
Anzeige
AW: link zur ursprünglichen Frage
25.11.2020 21:51:01
stef26
Hallo Matthias,
werde das später gleich nochmal testen.
Besten Dank auch noch für deine Mühe mir die Variante 2 zu machen.
Bei weitem mehr als man erwarten durfte.
Herzlichen Dank für deine Großartige Unterstützung.
Liebe Grüße und 1000x Dank
Stefan

143 Forumthreads zu ähnlichen Themen

Anzeige
Anzeige
Anzeige

Links zu Excel-Dialogen

Beliebteste Forumthreads (12 Monate)

Anzeige

Beliebteste Forumthreads (12 Monate)

Anzeige
Anzeige
Anzeige