Worddateien durchsuchen - Zeile kopieren...

Frage: Viele Worddokumente (in einem frei wählbaren Ordner - optional mit Unterordner) werden nach einem bestimmten Text durchsucht. Wird der Text gefunden kopiert der Code die ganze Zeile von Word nach Excel. Der Dateiname wird ebenfalls ausgegeben und verlinkt.

Many Word Documents (in a user-specified folder - optionally with subfolders) can be searched for specific text. If the text is found, the code copies the entire row from Word to Excel. The file name is also displayed and linked.

Hier noch eine Beispieldatei / Here's a sample file:
Worddateien durchsuchen - Zeile kopieren...[ZIP 200 KB]

Option Explicit
Private Declare Function GetCurrentDirectory Lib "kernel32" _
    Alias "GetCurrentDirectoryA" _
    (ByVal nBufferLength&, ByVal lpBuffer$) As Long
Private Declare Function SetCurrentDirectory Lib "kernel32" _
    Alias "SetCurrentDirectoryA" _
    (ByVal lpPathName$) As Long
' Der Suchtext - also anpassen!!! 
Const strSearchTMP As String = "kopiert"
Const strEXT As String = "*.dot*"
Private strList1() As String
Private strList() As String
Private blnTMP As Boolean
Private lngCount As Long
Private objFSO As Object
Private objApp As Object
'-------------------------------------------------------------------------- 
' Module    : Module1 
' Procedure : Main 
' Author    : Case (Ralf Stolzenburg) 
' Date      : 04.01.2013 
' Purpose   : Word - search documents - copy line... 
'-------------------------------------------------------------------------- 
Public Sub Main()
    Dim strListing As String
    Dim strDirOld As String
    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
    lngCount = 0
    strDirOld$ = String(255, 0)
    Call GetCurrentDirectory(255, strDirOld$)
    strDirOld$ = Left(strDirOld$, _
        InStr(1, strDirOld$, vbNullChar) - 1)
    If funcDirectory(strListing) <> "" Then
        Set objFSO = CreateObject("Scripting.FileSystemObject")
        Set objApp = OffApp("Word")
        ' Word nicht sichtbar 
        'Set objApp = OffApp("Word", False) 
        If Not objApp Is Nothing Then
            ' MIT Unterordner 
            'SearchFiles strListing, strEXT, True 
            ' OHNE Unterordner 
            SearchFiles strListing, strEXT
        End If
        If lngCount = 0 Then
            MsgBox "No file found with the search text!"
        Else
            With Sheet1
                .Cells.Clear
                .Range(.Cells(1, 1), Cells(lngCount, 1)) = _
                    WorksheetFunction.Transpose(strList)
                .Range(.Cells(1, 2), Cells(lngCount, 2)) = _
                    WorksheetFunction.Transpose(strList1)
            End With
            ' CodeName des Tabellenblattes hier englische Version 
            Call HyLink(Sheet1)
        End If
    End If
Fin:
    ' Die Applikation aufwecken 
    With Application
        .ScreenUpdating = True
        .AskToUpdateLinks = True
        .EnableEvents = True
        .Calculation = lngCalc
        .DisplayAlerts = True
        .CutCopyMode = True
    End With
    If Not objApp Is Nothing Then objApp.Quit
    Call SetCurrentDirectory(strDirOld$)
    Set objApp = Nothing
    Set objFSO = Nothing
    ' Wenn ein Fehler auftritt gib ihn aus mit Fehlernummer und Beschreibung 
    If Err.Number <> 0 Then MsgBox "Error: " & _
        Err.Number & " " & Err.Description
End Sub
Private Sub SearchFiles(strFolder As String, strFileName As String, _
    Optional blnTMP As Boolean = False)
    Dim objFolder As Object
    Dim objRange As Object
    Dim objFile As Object
    For Each objFile In objFSO.GetFolder(strFolder).Files
        If objFile.Name Like strFileName Then
            objApp.Documents.Open objFile.Path
            With objApp.Selection.Find
                .Forward = True
                .Text = strSearchTMP
                If .Execute = True Then
                    Redim Preserve strList1(lngCount)
                    Redim Preserve strList(lngCount)
                    Set objRange = objApp.Selection.Bookmarks("\Line").Range
                    strList1(lngCount) = objRange.Text
                    strList(lngCount) = objFile.Path
                    lngCount = lngCount + 1
                    objApp.ActiveDocument.Close False
                    Set objRange = Nothing
                Else
                    objApp.ActiveDocument.Close False
                End If
            End With
        End If
    Next objFile
    If blnTMP = True Then
        For Each objFolder In objFSO.GetFolder(strFolder).Subfolders
            SearchFiles strFolder & "\" & objFolder.Name, _
                strFileName, blnTMP
        Next
    End If
End Sub
Private Function funcDirectory(strDirectory As String) As String
    With Application.FileDialog(msoFileDialogFolderPicker)
        .InitialFileName = "C:\"
        .Title = "Directory"
        .ButtonName = "Select..."
        .InitialView = msoFileDialogViewList
        If .Show = -1 Then
            strDirectory = .SelectedItems(1)
            If Right(strDirectory, 1) <> "\" _
                Then strDirectory = strDirectory & "\"
            funcDirectory = strDirectory
        Else
            funcDirectory = ""
        End If
    End With
End Function
Private Sub HyLink(objSheet As Object)
    Dim lngRow As Long
    With objSheet
        lngRow = .Range("A" & .Rows.Count).End(xlUp).Row
        For lngRow = 1 To lngRow
            .Hyperlinks.Add Anchor:=.Cells(lngRow, 1), _
                Address:=.Cells(lngRow, 1)
        Next lngRow
        .Columns("A:B").AutoFit
    End With
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)...