Word - bestimmte Werte nach Excel...

Frage: Es gibt eine ganze Menge von Worddokumenten, in denen in zwei Spalten (keine Tabelle, sondern Tabulatorgetrennt) Analysedaten und die entsprechenden Werte stehen. Es gibt noch Überschriften und am Ende ein paar Daten, die nicht benötigt werden. Diese brauche ich in Excel. Wie geht das?

Im Download ist das Exceldokument sowie ein paar Worddokumente mit Beispieldaten.

Hier noch eine Beispieldatei: Word - bestimmte Werte nach Excel...[ZIP 60 KB]

Option Explicit
Dim blnTMP As Boolean
'-------------------------------------------------------------------------- 
' Module    : Modul1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 05.12.2012 
' Purpose   : Aus Worddokumenten bestimmte Werte nach Excel übertragen... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    ' Dimensionieren der Variablen 
    Dim wksSheet As Worksheet
    Dim objDocument As Object
    Dim lngLastRow As Long
    Dim strDatei As String
    Dim strPfad As String
    Dim objApp As Object
    Dim lngCalc As Long
    ' Wenn ein Fehler auftritt gehe zu der angegebenen Sprungmarke 
    On Error GoTo Fin
    ' Die Excelapplikation wird ruhig gestellt 
    With Application
        .ScreenUpdating = False
        .EnableEvents = False
        lngCalc = .Calculation
        .Calculation = xlCalculationManual
        .DisplayAlerts = False
    End With
    ' Pfad anpassen - fester Pfad vorgeben 
    'strPfad = "C:\Temp\Word\" 
    ' Pfad anpassen - Worddateien sind im gleichen 
    'Verzeichnis wie diese Exceldatei 
    strPfad = ThisWorkbook.Path & Application.PathSeparator
    Set objApp = OffApp("Word")
    ' Word nicht sichtbar 
    'Set objApp = OffApp("Word", False) 
    If Not objApp Is Nothing Then
        ' Temporäres Tabellenblatt hinzufügen 
        Worksheets.Add After:=Worksheets(Worksheets.Count)
        Set wksSheet = ActiveSheet
        strDatei = Dir$(strPfad & "*.doc*", vbDirectory)
        Do While strDatei <> ""
            ' Worddokument öffnen 
            Set objDocument = objApp.Documents.Open _
                (strPfad & strDatei)
            ' Die erste Tabelle wird kopiert 
            'objDocument.Tables(1).Range.Copy 
            ' Der gesamte Inhalt wird kopiert 
            objDocument.Range.Copy
            ' und in das temporäre Tabellenblatt eigefügt 
            wksSheet.Paste
            ' Leerzellen in Splate B werden gelöscht 
            wksSheet.Columns(2).SpecialCells _
                (xlCellTypeBlanks).Delete Shift:=xlUp
            ' Werte aus Spalte D werden nachgerückt 
            wksSheet.Range("D6:D43").Copy wksSheet.Range("D1")
            ' Ameisenrennen um den kopierten Bereich beenden 
            ' und Zwischenspeicher leeren 
            Application.CutCopyMode = True
            ' Bestimme jetzt die Anzahl der Zeilen in Spalte A 
            With Tabelle1
                lngLastRow = IIf(IsEmpty(.Cells(.Rows.Count, 1)), _
                    .Cells(.Rows.Count, 1).End(xlUp).Row, .Rows.Count)
            End With
            ' Den Bereich aus dem temporären Tabellenblatt kopieren 
            wksSheet.Range("D1:D33").Copy
            ' Und TRANSPONIERT in Tabelle1 erste freie Zeile einfügen 
            Tabelle1.Cells(lngLastRow + 1, 1).PasteSpecial Transpose:=True
            With Application
                .GoTo Tabelle1.Range("A1"), True
                .CutCopyMode = True
            End With
            ' Dateiname in den Kommentar schreiben 
            Tabelle1.Cells(lngLastRow + 1, 1).AddComment.Text strDatei
            ' Worddokument ohne speichern schlissen 
            objDocument.Close False
            ' Die nächste Datei nehmen 
            strDatei = Dir$()
            ' Setze die Objektvariable auf Nothing 
            Set objDocument = Nothing
        Loop
        ' Temporäres Tabellenblatt löschen 
        wksSheet.Delete
    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
    ' Objektvariablen leeren 
    Set wksSheet = Nothing
    Set objDocument = Nothing
    Set objApp = Nothing
    ' Die Applikation aufwecken 
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    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)...