AW: Word - Tabelle durchsuchen...
01.12.2013 19:37:57
Case
Hallo, :-)
bezogen auf meine Word - Testdateien und den zweiten Code (Suchstring = Test4 - Ausgabe = 4):
Option Explicit
' Suchbegriff bei Bedarf anpassen
Const strSearchTMP As String = "Test4"
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 = objTable.Cell(objSearch.Range.Cells(1).RowIndex + 1, _
objSearch.Range.Cells(1).ColumnIndex).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
