Word - Tabelle durchsuchen - Zelleninhalt kopieren

Frage: In Spalte B stehen ab Zeile 1 die Namen von Worddokumenten in der Form "Test1.doc", "Test2.doc"... In diesen Dateien gibt es eine Tabelle. Dort soll der Begriff "Genehmigt" gesucht werden. Wird er gefunden, soll der Inhalt der Zelle rechts davon nach Excel in Spalte C kopiert werden. Wie geht das?

Hier noch eine Beispieldatei: Word - Tabelle - Wert suchen...

Folgendes noch beachten:
Zellenende Markierung: http://support.microsoft.com/kb/901125/de

Im ersten Code wird das über "Find" gelöst.

Option Explicit
' Suchbegriff bei Bedarf anpassen 
Const strSearchTMP As String = "Genehmigt"
Dim blnTMP As Boolean
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 05.10.2012 
' Purpose   : Word - Tabelle - Zelle auslesen... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    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
    On Error GoTo Fin
    ' Pfad anpassen für festen Pfad 
    'strPfad = "C:\Temp\" 
    ' Tabellenblattname anpassen 
    Set wksSheet = ThisWorkbook.Worksheets("Sheet1")
    ' Dateien sind im gleichen Ordner wie Exceldatei 
    strPfad = ThisWorkbook.Path & Application.PathSeparator
    Set objApp = OffApp("Word")
    ' Word nicht sichtbar 
    'Set objApp = OffApp("Word", False) 
    If Not objApp Is Nothing Then
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        With wksSheet
            .Columns(3).Clear
            lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 2)), _
                .Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count)
        End With
        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 
            If Dir$(strPfad & wksSheet.Cells(lngTMP, 2).Value) <> "" Then
                Set objDocument = objApp.Documents.Open _
                    (strPfad & wksSheet.Cells(lngTMP, 2).Value)
                If objDocument.Tables.Count >= 1 Then
                    Set objTable = objDocument.Tables(1)
                    objApp.Selection.Find.Forward = True
                    objApp.Selection.Find.Text = strSearchTMP
                    If objApp.Selection.Find.Execute = True Then
                        Set objCell = objApp.Selection.Cells(1).Next.Range
                        For intCount = 1 To objCell.Words.Count - 1
                            strTMP = strTMP & objCell.Words.Item(intCount).Text
                        Next intCount
                        wksSheet.Cells(lngTMP, 3).Value = strTMP
                    Else
                        wksSheet.Cells(lngTMP, 3).Value = "No table available"
                    End If
                    Set objCell = Nothing
                    objDocument.Close False
                Else
                    wksSheet.Cells(lngTMP, 3).Value = "Term not found"
                End If
            Else
                wksSheet.Cells(lngTMP, 3).Value = "No file"
            End If
            strTMP = ""
        Next lngTMP
    Else
        MsgBox "Application not installed!"
    End If
Fin:
    If Not objApp Is Nothing Then
        If blnTMP = True Then
            objApp.Quit
            blnTMP = False
        End If
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set objCell = Nothing
    Set objTable = Nothing
    Set objDocument = Nothing
    Set objApp = Nothing
    Set wksSheet = Nothing
    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

Im folgenden Code wird jede Zelle der Tabelle in Word durchsucht:

Option Explicit
' Suchbegriff bei Bedarf anpassen 
Const strSearchTMP As String = "Genehmigt"
Dim blnTMP As Boolean
'-------------------------------------------------------------------------- 
' Module    : Module2 
' Procedure : Main_1 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 05.10.2012 
' Purpose   : Word - Tabelle - Zelle auslesen... 
'-------------------------------------------------------------------------- 
Public Sub Main_1()
    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
    On Error GoTo Fin
    ' Pfad anpassen für festen Pfad 
    'strPfad = "C:\Temp\" 
    ' Tabellenblattname anpassen 
    Set wksSheet = ThisWorkbook.Worksheets("Sheet1")
    ' Dateien sind im gleichen Ordner wie Exceldatei 
    strPfad = ThisWorkbook.Path & Application.PathSeparator
    Set objApp = OffApp("Word")
    ' Word nicht sichtbar 
    'Set objApp = OffApp("Word", False) 
    If Not objApp Is Nothing Then
        Application.ScreenUpdating = False
        Application.DisplayAlerts = False
        With wksSheet
            .Columns(3).Clear
            lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 2)), _
                .Cells(.Rows.Count, 2).End(xlUp).Row, .Rows.Count)
        End With
        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 
            If Dir$(strPfad & wksSheet.Cells(lngTMP, 2).Value) <> "" Then
                Set objDocument = objApp.Documents.Open _
                    (strPfad & wksSheet.Cells(lngTMP, 2).Value)
                If objDocument.Tables.Count >= 1 Then
                    Set objTable = objDocument.Tables(1)
                    For Each objSearch In objTable.Range.Cells
                        If InStr(objSearch.Range.Text, strSearchTMP) > 0 Then
                            Set objCell = objSearch.Range.Cells(1).Next.Range
                        End If
                    Next objSearch
                    For intCount = 1 To objCell.Words.Count - 1
                        strTMP = strTMP & objCell.Words.Item(intCount).Text
                    Next intCount
                    wksSheet.Cells(lngTMP, 3).Value = strTMP
                Else
                    wksSheet.Cells(lngTMP, 3).Value = "No table available"
                End If
                Set objCell = Nothing
                objDocument.Close False
            Else
                wksSheet.Cells(lngTMP, 3).Value = "No file"
            End If
            strTMP = ""
        Next lngTMP
    Else
        MsgBox "Application not installed!"
    End If
Fin:
    If Not objApp Is Nothing Then
        If blnTMP = True Then
            objApp.Quit
            blnTMP = False
        End If
    End If
    Application.ScreenUpdating = True
    Application.DisplayAlerts = True
    Set objCell = Nothing
    Set objTable = Nothing
    Set objDocument = Nothing
    Set objApp = Nothing
    Set wksSheet = Nothing
    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

Beliebte Posts aus diesem Blog

Formeln - auch Array - per VBA eintragen...

Alle Dateien eines Ordners - Optional mit Unterordner

Excel -> Word in Textmarken (Bookmarks)...