Bestimmte Wörter aus Dateien finden und wegschreiben

Moderator: ModerationP

Re: Bestimmte Wörter aus Dateien finden und wegschreiben

Beitragvon 1Matthias » 03. Okt 2017, 08:52

Moin!
So hier nun eine überarbeitete Version.
Die Spalten A und B im Aktiven Sheet werden am Anfang geleert - da kommt ja dann die Auswertung rein.
Alle Dateien die geöffnet werden, werden namentlich in Spalte A aufgeführt. Auch dann, wenn kein Wert gefunden wurde. So kannst du sehen, ob er auch alle Dateien findet. In Spalte B werden weiterhin die gefundenen Werte je Datei gelistet. Da ist jetzt als Kriterium das @ am Anfang und das im Text dahinter ein Punkt vorkommt. Alles andere ist verworfen, so dass deine Werte gefunden werden sollten.
Das mit der docx it auch noch mit drin.
Den Pfad vorher noch anpassen.
Hoffe mal, dass ich dann nichts vergessen habe.
VG

Code: Alles auswählen
Option Explicit

Sub text_finden()
Dim wordobj As Object
Dim ablage As String
Dim fso As Object
Dim datei As Object
Dim text As String
Dim gefunden As Boolean
Dim eintrag As Long
Dim zeile As Long
Dim werte

Application.ScreenUpdating = False

ActiveSheet.Columns("A:B").ClearContents

Set fso = CreateObject("Scripting.FileSystemObject")
Set wordobj = CreateObject("Word.Application")

zeile = 1

'hier deinen Pfad eintragen
ablage = "C:\Users\ich\Desktop\umgebung"

'Dateien suchen
For Each datei In fso.GetFolder(ablage).Files
    If Right(datei.Name, 3) = "doc" Or Right(datei.Name, 4) = "docm" Or Right(datei.Name, 4) = "docx" Then
        wordobj.documents.Open (ablage & "\" & datei.Name)
           
        'If wordobj.activedocument.Unprotect.ProtectionType <> -1 Then wordobj.activedocument.Unprotect
        wordobj.Selection.WholeStory
        text = wordobj.Selection.text
        wordobj.activedocument.Close
        werte = text_suchen(text)
        ActiveSheet.Cells(zeile, 1) = datei.Name
       
        If werte <> "" Then
            werte = Split(werte, "###")
            For eintrag = 0 To UBound(werte) - 1
                ActiveSheet.Cells(zeile, 2) = werte(eintrag)
                zeile = zeile + 1
            Next eintrag
        End If
       
        If ActiveSheet.Cells(zeile, 1) = "" Then
            zeile = zeile + 1
        Else
            zeile = zeile + 2
        End If
    End If
Next datei

wordobj.Quit
Application.ScreenUpdating = True

MsgBox "fertig"
Set fso = Nothing
Set wordobj = Nothing
End Sub

Function text_suchen(text As String) As String
Dim neu
Dim temp
Dim i As Long
Dim pos  As Long
Dim eintrag As String

neu = Split(text, "@")

For i = 1 To UBound(neu)
    temp = Split(neu(i), " ")
    eintrag = temp(0)
    eintrag = Split(eintrag, Chr(10))(0)
    eintrag = Split(eintrag, Chr(13))(0)
    If InStr(1, eintrag, ".", vbTextCompare) > 0 Then
            text_suchen = text_suchen & "@" & eintrag & "###"
    End If
Next i

End Function
1Matthias
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 203
Registriert: 15. Aug 2017, 18:36

Re: Bestimmte Wörter aus Dateien finden und wegschreiben

Beitragvon Gast » 03. Okt 2017, 17:10

Hallo Martin,

vielen Dank.

Ich kann heute leider nicht prüfen, ob es funktioniert.

Mein kleiner ist krank geworden, musste mit ihm zum Arzt.

Ich schaue es mir morgen früh an und melde mich.

Vielen Dank noch mal :)
Gast
 

Re: Bestimmte Wörter aus Dateien finden und wegschreiben

Beitragvon Roland889 » 04. Okt 2017, 08:19

Hallo Martin,

vielen Dank.

Der Code funktioniert soweit :).

Zwei Fragen dazu:

Ist es möglich auch alle Wärter einzubeziehen die nur die Form haben wie:

@User

ohne Punkt dahinter?

Einige Wörter sind noch in folgender Form geschrieben

(@User.ID).

daraus macht er mir

@User.ID)

könnte man die Klammer zu noch wegnehmen?

Edit: noch eine Sache die mir aufgefallen ist, ich habe noch Text der folgenden Aufbau hat

@User<hier wird spezifiziert>.ID

Dieses Wort findet er gar nicht, es liegt an den Leerzeichen in den spitzen Klammern. Ich habe diese test weise mal raus genommen, sobald ich dieses mache, und das Wort dann die Form:

@User<hierwirdspezifiziert>.ID

hat, wird es auch gefunden. Könnte man das auch noch mit einbeziehen?

Ist der Code auch änderbar für andere Wörter?

Falls ja, wo müsste ich das ändern?

Edit2: Wäre es denn auch möglich sich die Seiten und Zeilenzahl des jeweiligen Textes mit auszugeben?

Zusätzlich ist mir aufgefallen, dass ich in den Dokumenten ein SHIFT+Return habe. Dadurch werden in Excel selbst ungewollte Zeichen mitgegeben.

Ich hab es schon probiert, leider klappt es nicht mit meinem Code. Wäre es denn noch möglich, dass wenn jedesmal wenn ein Dokument geöffnet wird, erst einmal nach SHIFT+Return gesucht wird und dieses gegen ein leerzeichen ausgetauscht wird?

Hier mal der Code den ich genutzt habe

Code: Alles auswählen
 With wordobj.Content.Find
        .Text = "5234"
        .Replacement.Text = Ersatzwort
        .Wrap = wdFindContinue
        .Execute Replace:=wdReplaceAll
    End With


Vielen Dank noch mal für deine Mühe und Hilfe

Viele Grüße

Roland
Roland889
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 25
Registriert: 11. Jun 2014, 10:34

Re: Bestimmte Wörter aus Dateien finden und wegschreiben

Beitragvon 1Matthias » 04. Okt 2017, 21:17

Moin!
Da hat aber die Edit Taste gehangen!? :-)
Also anbei mal die neue Funktion text_suchen. Die einfach im Code austauschen. Damit sollten deine Shift-Returns rausfallen. Zudem sollten auch User ohne Punkt und folgendem Text erfasst werden.
Die Klammer am Ende wäre auch weg und bei spitzen Klammern ist das Leerzeichen darin egal.
Dann ist der Code bisher so programmiert, dass er gar nicht nach USER sucht sondern einfach nur ob hinter dem @ was steht. Hatte das User für einen Platzhalter des Usernamens gehalten und nicht als fest vorgegebenen Wert. Damit sollte er also alles finden. Falls das eingeschränkt werde sollte, nochmal dazu melden.

MIt der Seiten und Zeilenanzahl meinst du den jeweiligen Treffer oder die Länge des Dokumententextes? Da war ich mir nicht ganz sicher.

Soweit erstmal. Bitte mal testen.
VG



Code: Alles auswählen
Function text_suchen(text As String) As String
Dim neu
Dim temp As String
Dim i As Long
Dim pos  As Long
Dim eintrag As String
Dim spitze2 As Long
Dim spitze1 As Long
Dim erstnull As Long



neu = Replace(text, Chr(11), "")
neu = Split(neu, "@")

For i = 1 To UBound(neu)
    eintrag = Split(neu(i), Chr(10))(0)
    eintrag = Split(eintrag, Chr(13))(0)
   
    spitze1 = InStr(1, eintrag, "<", vbTextCompare)
    spitze2 = InStr(1, eintrag, ">", vbTextCompare)
   
    If spitze2 > 0 And spitze1 > 0 Then
        erstnull = InStr(1, eintrag, " ", vbTextCompare)
        If spitze1 < spitze2 And spitze1 < erstnull Then
            temp = Left(eintrag, spitze2)
            eintrag = Left(temp, Len(temp) - 1) & Split(Mid(eintrag, spitze2), " ")(0)
        Else
            eintrag = ""
        End If
    Else
        eintrag = Split(eintrag, " ")(0)
    End If

    If Right(eintrag, 1) = ")" Then eintrag = Trim(Left(eintrag, Len(eintrag) - 1))
    If eintrag <> "" Then
            text_suchen = text_suchen & "@" & eintrag & "###"
    End If
Next i

End Function
1Matthias
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 203
Registriert: 15. Aug 2017, 18:36

Re: Bestimmte Wörter aus Dateien finden und wegschreiben

Beitragvon Roland889 » 05. Okt 2017, 11:54

Hallo,

ja da hat die Taste gehangen :D, nur von Ideen so gestrotzt. ^^

VIelen Dank das funktioniert soweit wunderbar.

Zwei Änderungswünsche hätte ich noch, wenn erlaubt:

Zu der Seitenzahl:
In Excel werden die gefundenen Werte ja in der zweiten Tabellenspalte geschrieben, könnte man daneben noch mal reinschreiben auf welcher Seite diese im Dokument vorkommen?
Bsp:
Spalte A Spalte B Spalte C
Dokument 1 @UserID Seite 3

Könnte man denn alles was ungleich eine @User<Spezifizieren>.ID ist nicht mit aufnehmen?
Ich habe noch viele Werte die folgenden aufbau haben
@User.ID), draus sollte werden @User.ID
@User.Typ==xyz daraus sollte werden @User.Typ
@User.ID> daraus sollte @User.ID werden.

Ich hoffe ich habe es verständlich erklären können ^^

Viele Grüße

Roland
Roland889
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 25
Registriert: 11. Jun 2014, 10:34

Re: Bestimmte Wörter aus Dateien finden und wegschreiben

Beitragvon 1Matthias » 05. Okt 2017, 15:01

Moin!
Wird aber erst morgen was.
Mal noch ein paar Fragen zu der "Filterung" am Ende - bevor es wieder ein Mißverständnis gibt. :-)
Zu:
1. @User<Spezifizieren>.ID
Dabei soll User als Wort feststehen und nur Spezifizieren und ID flexibel sein? Und das soll auch nur für Werte mit <> gelten? Soll spezifizieren mehrere Werte haben oder nur einen?
2. @User.ID)
Sollte eigentlich schon rausgenommen werden. Schaue aber nochmal.
3. @User.Typ==xyz
Dabei sind User fest und Typ Variabel? Das == ist dann der Trenner und alles danach soll weg?

Notfalls mal zu jedem Wert 2 Beispiele schreiben, damit ich erkenne, was fest steht und was flexibel.

VG
1Matthias
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 203
Registriert: 15. Aug 2017, 18:36

Re: Bestimmte Wörter aus Dateien finden und wegschreiben

Beitragvon Roland889 » 05. Okt 2017, 15:49

Hallo,

kein Problem :)

zu 1.
User ist austauschbar gegen viele anderen Wörter. Spezifizieren und ID sollen flexibel sein.
Bsp.
@User<Auslöser>.ID
@User<Empfänger>.ID

zu 2.)
Das kommt leider noch öfters vor auch noch hier Beispiele:
@User.ID),
@User.ID==
@User.Name)WENN

hier wäre nur
@User.ID
wünschenswert

@User und .ID ist nur ein Bsp. das ist variabel.

Noch eine Bitte.

Ich habe noch öfters Einträge wie
@User.

könnte man, wenn nach einem Punkt nichts mehr kommt diesen auch noch entfernen, so dass ich dann nur die Form
@User
habe?

Viele Grüße

Roland
Roland889
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 25
Registriert: 11. Jun 2014, 10:34

Re: Bestimmte Wörter aus Dateien finden und wegschreiben

Beitragvon 1Matthias » 05. Okt 2017, 22:24

Moin!
Letzte Zwischenfrage für heute - bevor morgen das Programmieren los geht.
Ist ID nur eine Zahlenkombination oder kann das auch Text etc. sein. Geht darum das Trennen so flexibel wie möglich zu machen. Falls es Zahlen sind, könnte man sonst schauen, dass wenn nach User ein Punkt kam, alles was Zahl ist noch dazu zählt und der Rest entfernt wird.
VG
1Matthias
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 203
Registriert: 15. Aug 2017, 18:36

Re: Bestimmte Wörter aus Dateien finden und wegschreiben

Beitragvon Gast » 06. Okt 2017, 06:09

Hallo,

Id kann auch ein Text sein.

Ich glaube zahlen habe ich gar nicht, da es nur textlich erläutert wird alles.
Genau, das trennen soll so flexibel wie möglich sein :)
Gast
 

Re: Bestimmte Wörter aus Dateien finden und wegschreiben

Beitragvon theoS » 06. Okt 2017, 08:15

Hallo Roland,
ich finde es toll von Matthias, wie er dich unterstützt, obwohl er eigentlich vollkommen im Dunklen tappt - du könntest es ihm aber auch viel leichter machen:
Melde dich hier an und lade eine Beispieldatei hoch. Am besten 2, eine mit dem Ist-Daten und eine, wie das dann aussehen soll.

:-)
theo s.
Benutzeravatar
theoS
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 3691
Registriert: 19. Apr 2008, 00:14

Re: Bestimmte Wörter aus Dateien finden und wegschreiben

Beitragvon 1Matthias » 06. Okt 2017, 19:08

Moin!
So ich hoffe mal, dass dies jetzt alles Punkte abdeckt.
MÜsstest auch den Code der Sub austauschen und deinen Pfad wieder anpassen. VG

Code: Alles auswählen
Option Explicit

Sub text_finden()
Dim wordobj As Object
Dim ablage As String
Dim fso As Object
Dim datei As Object
Dim text As String
Dim gefunden As Boolean
Dim eintrag As Long
Dim zeile As Long
Dim werte
Dim seiten As Long
Dim seite As Long
Dim temp
Dim blätter

Application.ScreenUpdating = False

ActiveSheet.Columns("A:C").ClearContents

Set fso = CreateObject("Scripting.FileSystemObject")
Set wordobj = CreateObject("Word.Application")

zeile = 1

'hier deinen Pfad eintragen
ablage = "C:\Users\ich\Desktop\umgebung"

'Dateien suchen
For Each datei In fso.GetFolder(ablage).Files
    If Right(datei.Name, 3) = "doc" Or Right(datei.Name, 4) = "docm" Or Right(datei.Name, 4) = "docx" Then
        Set temp = wordobj.documents.Open(ablage & "\" & datei.Name)
           
        'If wordobj.activedocument.Unprotect.ProtectionType <> -1 Then wordobj.activedocument.Unprotect
        seiten = temp.BuiltinDocumentProperties(14)
        text = ""
        For seite = 1 To seiten
            wordobj.Selection.GoTo 1, 2, , seite
            wordobj.Selection.Bookmarks("\Page").Range.Select
            text = text & wordobj.Selection.text & "#+#+#"
        Next seite
       
        wordobj.activedocument.Close
           
        ActiveSheet.Cells(zeile, 1) = datei.Name
               
        blätter = Split(text, "#+#+#")
        For seite = 0 To UBound(blätter) - 1
            werte = text_suchen(blätter(seite))
            If werte <> "" Then
                werte = Split(werte, "###")
                For eintrag = 0 To UBound(werte) - 1
                    ActiveSheet.Cells(zeile, 2) = werte(eintrag)
                    ActiveSheet.Cells(zeile, 3) = "Seite " & seite + 1
                    zeile = zeile + 1
                Next eintrag
            End If
        Next seite
       
        If ActiveSheet.Cells(zeile, 1) = "" Then
            zeile = zeile + 1
        Else
            zeile = zeile + 2
        End If
    End If
Next datei

wordobj.Quit
Application.ScreenUpdating = True

MsgBox "fertig"
Set fso = Nothing
Set wordobj = Nothing
End Sub

Function text_suchen(ByVal text As String) As String
Dim neu
Dim temp As String
Dim i As Long
Dim j As Long
Dim pos  As Long
Dim eintrag As String
Dim spitze2 As Long
Dim spitze1 As Long
Dim erstnull As Long
Dim ersatz()

ersatz = Array(")", "==")


neu = Replace(text, Chr(11), "")
neu = Split(neu, "@")

For i = 1 To UBound(neu)
    eintrag = Split(neu(i), Chr(10))(0)
    eintrag = Split(eintrag, Chr(13))(0)
   
    spitze1 = InStr(1, eintrag, "<", vbTextCompare)
    spitze2 = InStr(1, eintrag, ">", vbTextCompare)
   
    If spitze2 > 0 And spitze1 > 0 Then
        erstnull = InStr(1, eintrag, " ", vbTextCompare)
        If erstnull = 0 Then erstnull = Len(eintrag) + 1
        If spitze1 < spitze2 And spitze1 < erstnull Then
            temp = Left(eintrag, spitze2)
            eintrag = Left(temp, Len(temp) - 1) & Split(Mid(eintrag, spitze2), " ")(0)
        Else
            eintrag = ""
        End If
    Else
        eintrag = Split(eintrag, " ")(0)
    End If
   
    For j = 0 To UBound(ersatz)
        temp = InStr(1, eintrag, ersatz(j), vbTextCompare)
        If temp > 0 Then eintrag = Trim(Left(eintrag, temp - 1))
    Next j

    If InStr(1, eintrag, ">", vbTextCompare) > 0 And InStr(1, eintrag, "<", vbTextCompare) = 0 Then
        temp = InStr(1, eintrag, ">", vbTextCompare) - 1
        eintrag = Trim(Left(eintrag, temp - 1))
    End If
   
    If eintrag <> "" Then
            text_suchen = text_suchen & "@" & eintrag & "###"
    End If
Next i

End Function
1Matthias
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 203
Registriert: 15. Aug 2017, 18:36

Re: Bestimmte Wörter aus Dateien finden und wegschreiben

Beitragvon Gast » 09. Okt 2017, 07:36

Hallo,
tut mir leid für die späte Antwort, plage mich mit einer Grippe rum :cry:
Danke für die Änderungen.
Leider habe ich jetzt das Problem, dass viele Werte nicht mehr gefunden werden.
D.h. viele Werte mit der Form @User.ID werden nicht mehr gefunden
Danke noch mal für deine Hilfe
Viele Grüße
Gast
 

Re: Bestimmte Wörter aus Dateien finden und wegschreiben

Beitragvon Gast » 09. Okt 2017, 07:39

Edit: Noch mal nachgeschaut, alles mit der Form @Wert.ABC wird nicht mehr gefunden leider
Gast
 

Re: Bestimmte Wörter aus Dateien finden und wegschreiben

Beitragvon Gast » 09. Okt 2017, 16:05

Hallo,
ich habe noch mal heute ein wenig probiert.
Das Problem scheint zu sein, dass das Makro nur bis zur Seite 2 sucht und danach alles abschneidet.
Ich habe in meinen Dokumenten verschiedene Werte zum testen eingetragen und dies dabei festgestellt.
Alles was nach der Seite 2 kommt, wird ignoriert.
Die Form @User.ID wird aber auch gefunden, das Problem liegt darin, dass nur bis zur zweiten Seite gesucht wird.
Gast
 

Re: Bestimmte Wörter aus Dateien finden und wegschreiben

Beitragvon 1Matthias » 09. Okt 2017, 19:47

Moin!
Jetzt muss ich doch mal bitten, so eine Datei mit deinen Werten hochzuladen. Habe eben in meiner Testdatei mal bis Seite 8 die Seitenanzahl verlängert. Dort findet er noch die eingetragenen Werte.
Du kann ja auch mal im VBE bei der Zeile mit
For seite = 1 To seiten
einen Haltepunkt setzen und dann schauen, was die Variable Seiten anzeigt. Dort sollte die Gesamtseitenzahl stehen.
Falls das nicht passt mal die Zeile hier
Code: Alles auswählen
seiten = temp.BuiltinDocumentProperties(14)

durch das ersetzen
Code: Alles auswählen
temp.Range.Select
seiten = wordobj.Selection.Information(4)

Das ist eine andere Variante um alle Seitenzahlen anzuzeigen - damit sollte es klappen - wie geschrieben bei mir mit beiden Varianten.

VG
1Matthias
Im Profil kannst Du frei den Rang ändern
 
Beiträge: 203
Registriert: 15. Aug 2017, 18:36

VorherigeNächste

Zurück zu Word Forum (provisorisch)

Wer ist online?

Mitglieder in diesem Forum: 0 Mitglieder und 3 Gäste