Von Wordtabelle eine Zelle nach Excel

Frage: Es sind mehrere Worddateien (ca. 130 Tendenz steigend) in einem Ordner vorhanden. Jede Worddatei ist gleich aufgebaut und beinhaltet eine Tabelle. Ich möchte nun von jeder Worddatei eine bestimmte Zelle dieser Tabellen nach Excel transferieren (untereinander aufgelistet). Problem ist noch, dass in den Zellen sogenannte "Zellenende Markierung" sind - die müssen natürlich weg. Wie geht das?

Zellenende Markierung: http://support.microsoft.com/kb/901125/de
Option Explicit
Dim blnTMP As Boolean
Public Sub Test()
    Dim objDocument As Object
    Dim strDatei As String
    Dim strPfad As String
    Dim objApp As Object
    On Error GoTo Fin
    ' Pfad anpassen
    strPfad = "C:\Temp\"
    Set objApp = OffApp("Word")
    ' Word nicht sichtbar
    'Set objApp = OffApp("Word", False)
    If Not objApp Is Nothing Then
        Columns(1).Clear
        strDatei = Dir$(strPfad & "*.doc*", vbDirectory)
        Do While strDatei <> ""
            Set objDocument = objApp.Documents.Open _
                (strPfad & strDatei)
            Range("A" & Rows.Count).End(xlUp).Offset(1, 0).Value = _
                Replace(objDocument.Tables(1).Cell(4, 2).Range, _
                Chr(13) & Chr(7), "")
            objDocument.Close False
            strDatei = Dir$()
        Loop
    Else
        MsgBox "Applikation nicht installiert!"
    End If
Fin:
    If Not objApp Is Nothing Then
        If blnTMP = True Then
            objApp.Quit
            blnTMP = False
        End If
    End If
    Set objApp = Nothing
    If Err.Number <> 0 Then MsgBox "Fehler: " & _
        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)...