04.07.2023, 16:45
Moin, 
In einer Worddatei ist eine Tabelle. Dort suche ich ein Wort. Der Inhalt der Zelle daneben soll nach Excel kopiert werden. Dateinamen stehen in Spalte B in Tabelle1. Code ausreichend kommentiert.
Modul1 (Da ist es mit "Find" gelöst):
Modul2 (Da ist es mit "For Each" gelöst):
[attachment=48652]
In einer Worddatei ist eine Tabelle. Dort suche ich ein Wort. Der Inhalt der Zelle daneben soll nach Excel kopiert werden. Dateinamen stehen in Spalte B in Tabelle1. Code ausreichend kommentiert.
Modul1 (Da ist es mit "Find" gelöst):
Code:
' Variablendeklaration erforderlich.
Option Explicit
' Suchbegriff bei Bedarf anpassen
Const strSearchTMP As String = "Genehmigt"
Dim blnTMP As Boolean
'################################################################################################
' Module : Modul1
' Procedure : Main_1
' Author : Case (Ralf Stolzenburg)
' Date : 04.07.2023
' Purpose : Word - Tabelle - Zelle auslesen. Mit Find...
' Purpose : Veröffentlicht auf CEF "https://www.clever-excel-forum.de/index.php" am 04.07.2023.
' Purpose : In der Rubrik "Beispiele und Workshops" unter "mit VBA".
'################################################################################################
Public Sub Main_1()
' Variablendeklaration
Dim wksSheet As Worksheet
Dim objDocument As Object
Dim intCount As Integer
Dim lngLastRow As Long
Dim objTable As Object
Dim strPfad As String
Dim objCell As Object
Dim strTMP As String
Dim objApp As Object
Dim lngTMP As Long
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke.
On Error GoTo Fin
' Pfad anpassen für festen Pfad.
'strPfad = "C:\Temp\"
' Tabellenblattname bei Bedarf anpassen. Er wird hier einer Objektvariablen zugewiesen.
Set wksSheet = ThisWorkbook.Worksheets("Tabelle1")
' Dateien sind im gleichen Ordner wie diese Exceldatei.
strPfad = ThisWorkbook.Path & Application.PathSeparator
' Die entsprechende Applikation wird sichtbar gestartet - hier Word.
Set objApp = OffApp("Word")
' Word nicht sichtbar.
'Set objApp = OffApp("Word", False)
' Wenn die Objektvariable NICHT Nothing ist, dann...
If Not objApp Is Nothing Then
' Bildschirmaktualisierung ausschalten.
Application.ScreenUpdating = False
' Fehleranzeige ausschalten.
Application.DisplayAlerts = False
' Mit With beziehe ich mich auf ein bestimmtes Objekt - hier die Objektvariable "wksSheet".
' Alles was sich auf dieses Objekt bezieht muss mit einem Punkt beginnen.
' Da Objekt selber muss nicht mehr genannt werden.
With wksSheet
' Spalte 3 - also Spalte C Inhalt löschen.
.Columns(3).ClearContents
' Letze belegte Zelle in Spalte B der Variablen zuweisen.
lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 2)), .Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count)
End With
' Schleife von 1 bis zur letzten Zelle Spalte B.
For lngTMP = 1 To lngLastRow
' Wenn OHNE Endung ".doc" in Spalte B, dann diese Zeile
'strDatei = Dir$(strPfad & .Cells(lngTMP, 2).Value & ".doc*")
' Wenn MIT Endung ".doc" in Spalte B, dann diese Zeile
' Ist die Datei im Pfad mit Namen vorhanden, dann...
If Dir$(strPfad & wksSheet.Cells(lngTMP, 2).Value) <> "" Then
' Die Datei öffnen und einer Objektvariablen zuordnen.
Set objDocument = objApp.Documents.Open(strPfad & wksSheet.Cells(lngTMP, 2).Value)
' Prüfung, ob überhaupt eine Tabelle im Worddukument ist, dann...
If objDocument.Tables.Count >= 1 Then
' Die Tabelle einer Objektvariablen zuweisen.
Set objTable = objDocument.Tables(1)
' Siehe https://learn.microsoft.com/de-de/office/vba/api/word.selection
' Das Dokument wird vorwärts durchsucht. Mit False rückwärts.
objApp.Selection.Find.Forward = True
' Was soll gesucht werden?
objApp.Selection.Find.Text = strSearchTMP
' Der Suchvorgang wird ausgeführt und bei Erfolg True zurückgegeben.
If objApp.Selection.Find.Execute = True Then
' In der NÄCHSTEN Zelle den Bereich einer Objektvariablen zuweisen.
Set objCell = objApp.Selection.Cells(1).Next.Range
' Mit einer Schleife die Wörter abklappern.
For intCount = 1 To objCell.Words.Count - 1
' Die Stringvariable füllen. Lässt sich auch einfacher kopieren.
' Hier nur als Beispiel, wenn z. B. nur bestimmte Wörter genommen werden sollen.
strTMP = strTMP & objCell.Words.Item(intCount).Text
Next intCount
' Und in Spalte C der entsprechenden Zelle eintragen.
wksSheet.Cells(lngTMP, 3).Value = strTMP
Else
' Der Suchbegriff wurde nicht gefunden. Ausgabe Fehler in Spalte C.
wksSheet.Cells(lngTMP, 3).Value = "Suchbegriff nicht gefunden..."
End If
' Objektvariable zurücksetzen.
Set objCell = Nothing
' Worddokument OHNE speichern schlißen.
objDocument.Close False
Else
' Es ist keine Tabelle im gerade geöffneten Worddokument. Ausgabe Fehler in Spalte C.
wksSheet.Cells(lngTMP, 3).Value = "Keine Tabelle im Worddokument..."
End If
Else
' Datei ist nicht vorhanden. Ausgabe Fehler in Spalte C.
wksSheet.Cells(lngTMP, 3).Value = "Datei nicht vorhanden..."
End If
' Stringvariable "strTMP" leeren
strTMP = vbNullString
' Dateiname aus nächster Zelle holen.
Next lngTMP
Else
' Kein Word vorhanden.
MsgBox "Applikation nicht installiert..."
End If
Fin:
' Ist die App überhaupt gestartet, wenn ja dann...
If Not objApp Is Nothing Then
' Wenn die Boolsche Variable True ist, dann...
If blnTMP = True Then
' Beende die App. Sonst bleibt Word offen.
objApp.Quit
blnTMP = False
End If
End If
' Bildschirmaktualisierung einschalten - geht nach Ende das Makros eigentlich automatisch.
' Habe mir aber angewöhnt das immer zu schreiben, denn andere Eigenschaften SOLLTE (M)man(n)
' noch einschalten, wenn ausgeschaltet (Application.DisplayAlerts). Also es schadet nicht. :-)
Application.ScreenUpdating = True
' Wird eigentlich auch wieder am Ende eingeschaltet. Kann problematisch werden, wenn ein Fehler auftritt
' und der nicht abgefangen wird, ODER wenn prozessübergreifend prgrammiert wird. Also lieber einschalten!!!
Application.DisplayAlerts = True
' Objektvariablen zurücksetzen. Geht auch automatisch, aber siehe oben.
Set objCell = Nothing
Set objTable = Nothing
Set objDocument = Nothing
Set objApp = Nothing
Set wksSheet = Nothing
' Wenn ein Fehler aufgetreten ist gib ihn mit Nummer rund Beschreibung aus, sonst weiter.
If Err.Number <> 0 Then MsgBox "Error: " & Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, Optional blnVisible As Boolean = True) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, strApp & ".Application")
Select Case Err.Number
Case 429
Err.Clear
Set objApp = CreateObject(strApp & ".Application")
blnTMP = True
If blnVisible = True Then
On Error Resume Next
objApp.Visible = True
Err.Clear
End If
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End FunctionModul2 (Da ist es mit "For Each" gelöst):
Code:
' Variablendeklaration erforderlich.
Option Explicit
' Suchbegriff bei Bedarf anpassen
Const strSearchTMP As String = "Genehmigt"
Dim blnTMP As Boolean
'################################################################################################
' Module : Modul1
' Procedure : Main_2
' Author : Case (Ralf Stolzenburg)
' Date : 04.07.2023
' Purpose : Word - Tabelle - Zelle auslesen. Mit For Each...
' Purpose : Veröffentlicht auf CEF "https://www.clever-excel-forum.de/index.php" am 04.07.2023.
' Purpose : In der Rubrik "Beispiele und Workshops" unter "mit VBA".
'################################################################################################
Public Sub Main_2()
' Variablendeklaration
Dim wksSheet As Worksheet
Dim objDocument As Object
Dim objSearch As Object
Dim intCount As Integer
Dim lngLastRow As Long
Dim objTable As Object
Dim strPfad As String
Dim objCell As Object
Dim strTMP As String
Dim objApp As Object
Dim lngTMP As Long
' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke.
On Error GoTo Fin
' Pfad anpassen für festen Pfad
'strPfad = "C:\Temp\"
' Tabellenblattname bei Bedarf anpassen. Er wird hier einer Objektvariablen zugewiesen.
Set wksSheet = ThisWorkbook.Worksheets("Tabelle1")
' Dateien sind im gleichen Ordner wie Exceldatei.
strPfad = ThisWorkbook.Path & Application.PathSeparator
' Die entsprechende Applikation wird sichtbar gestartet - hier Word.
Set objApp = OffApp("Word")
' Word nicht sichtbar
'Set objApp = OffApp("Word", False)
' Wenn die Objektvariable NICHT Nothing ist, dann...
If Not objApp Is Nothing Then
' Bildschirmaktualisierung ausschalten.
Application.ScreenUpdating = False
' Fehleranzeige ausschalten.
Application.DisplayAlerts = False
' Mit With beziehe ich mich auf ein bestimmtes Objekt - hier die Objektvariable "wksSheet".
' Alles was sich auf dieses Objekt bezieht muss mit einem Punkt beginnen.
' Da Objekt selber muss nicht mehr genannt werden.
With wksSheet
' Spalte 3 - also Spalte C Inhalt löschen.
.Columns(3).ClearContents
' Letze belegte Zelle in Spalte B der Variablen zuweisen.
lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 2)), .Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count)
End With
' Schleife von 1 bis zur letzten Zelle Spalte B.
For lngTMP = 1 To lngLastRow
' Wenn OHNE Endung ".doc" in Spalte B, dann diese Zeile
'strDatei = Dir$(strPfad & .Cells(lngTMP, 2).Value & ".doc*")
' Wenn MIT Endung ".doc" in Spalte B, dann diese Zeile
' Ist die Datei im Pfad mit Namen vorhanden, dann...
If Dir$(strPfad & wksSheet.Cells(lngTMP, 2).Value) <> "" Then
' Die Datei öffnen und einer Objektvariablen zuordnen.
Set objDocument = objApp.Documents.Open(strPfad & wksSheet.Cells(lngTMP, 2).Value)
' Prüfung, ob überhaupt eine Tabelle im Worddukument ist, dann...
If objDocument.Tables.Count >= 1 Then
' Die Tabelle einer Objektvariablen zuweisen.
Set objTable = objDocument.Tables(1)
' Gehe durch jede Zelle der Tabelle im Worddokument.
For Each objSearch In objTable.Range.Cells
' Wenn das Suchwort in der Zelle vorkommt, dann...
If InStr(objSearch.Range.Text, strSearchTMP) > 0 Then
' In der NÄCHSTEN Zelle den Bereich einer Objektvariablen zuweisen.
Set objCell = objSearch.Range.Cells(1).Next.Range
End If
' Die nächste Zelle nehmen.
Next objSearch
' Mit einer Schleife die Wörter abklappern.
For intCount = 1 To objCell.Words.Count - 1
' Die Stringvariable füllen. Lässt sich auch einfacher kopieren.
' Hier nur als Beispiel, wenn z. B. nur bestimmte Wörter genommen werden sollen.
strTMP = strTMP & objCell.Words.Item(intCount).Text
Next intCount
' Und in Spalte C der entsprechenden Zelle eintragen.
wksSheet.Cells(lngTMP, 3).Value = strTMP
Else
' Es ist keine Tabelle im gerade geöffneten Worddokument. Ausgabe Fehler in Spalte C.
wksSheet.Cells(lngTMP, 3).Value = "Keine Tabelle im Worddokument..."
End If
' Objektvariable zurücksetzen.
Set objCell = Nothing
' Worddokument OHNE speichern schlißen.
objDocument.Close False
Else
' Datei ist nicht vorhanden. Ausgabe Fehler in Spalte C.
wksSheet.Cells(lngTMP, 3).Value = "Datei nicht vorhanden..."
End If
' Stringvariable "strTMP" leeren
strTMP = vbNullString
' Dateiname aus nächster Zelle holen.
Next lngTMP
Else
' Kein Word vorhanden.
MsgBox "Applikation nicht installiert..."
End If
Fin:
' Ist die App überhaupt gestartet, wenn ja dann...
If Not objApp Is Nothing Then
' Wenn die Boolsche Variable True ist, dann...
If blnTMP = True Then
' Beende die App. Sonst bleibt Word offen.
objApp.Quit
blnTMP = False
End If
End If
' Bildschirmaktualisierung einschalten - geht nach Ende das Makros eigentlich automatisch.
' Habe mir aber angewöhnt das immer zu schreiben, denn andere Eigenschaften SOLLTE (M)man(n)
' noch einschalten, wenn ausgeschaltet (Application.DisplayAlerts). Also es schadet nicht. :-)
Application.ScreenUpdating = True
' Wird eigentlich auch wieder am Ende eingeschaltet. Kann problematisch werden, wenn ein Fehler auftritt
' und der nicht abgefangen wird, ODER wenn prozessübergreifend prgrammiert wird. Also lieber einschalten!!!
Application.DisplayAlerts = True
' Objektvariablen zurücksetzen. Geht auch automatisch, aber siehe oben. Set objCell = Nothing
Set objTable = Nothing
Set objDocument = Nothing
Set objApp = Nothing
Set wksSheet = Nothing
' Wenn ein Fehler aufgetreten ist gib ihn mit Nummer rund Beschreibung aus, sonst weiter.
If Err.Number <> 0 Then MsgBox "Error: " & Err.Number & " " & Err.Description
End Sub
Private Function OffApp(ByVal strApp As String, Optional blnVisible As Boolean = True) As Object
Dim objApp As Object
On Error Resume Next
Set objApp = GetObject(, strApp & ".Application")
Select Case Err.Number
Case 429
Err.Clear
Set objApp = CreateObject(strApp & ".Application")
blnTMP = True
If blnVisible = True Then
On Error Resume Next
objApp.Visible = True
Err.Clear
End If
End Select
On Error GoTo 0
Set OffApp = objApp
Set objApp = Nothing
End Function