[Excel] Word - Tabelle - Wert suchen Zelle daneben nach Excel...
#1
Moin, 19 

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. 21 

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 Function

Modul2 (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
[attachment=48652]
Antworten Top


Gehe zu:


Benutzer, die gerade dieses Thema anschauen: 1 Gast/Gäste