[vba]워드문서 검색하여 엑셀파일에 복사하기

wordfindtoexcel.xlsm

0.02MB

엑셀에서 매크로를 실행하여

특정 폴더안의 모든 워드 문서 중에서 

본문에 특정한 단어가 있는지 검사한 후

해당 단어가 있는 문장과

문장의 첫단어가 있는 라인 수

해당 파일의 이름을 출력하는 매크로이다

VB편집기에서

도구 - 참조 클릭하고

Microsoft Word Object Library에 체크를 해야 작동한다.

Option Explicit

Sub macro()
Dim WApp As Object, WDoc As Object, WDR As Object
Dim ExR As Range, sPath As String
Dim str2Find As String, myData As String, sFname As String, myfile As String
Dim myline As Long

    Set ExR = Range("A1") '찾는 단어가 있는 셀
    
    str2Find = ExR.Value

    With Application.FileDialog(msoFileDialogFolderPicker)
        .Title = "폴더를 고르시오"
        .Show
        If .SelectedItems.Count = 0 Then
            MsgBox "Canceled"
            Exit Sub
        Else
            sPath = .SelectedItems(1) & "\"
        End If
    End With
    
    Set WApp = CreateObject("Word.Application")
    sFname = Dir(sPath & "*.doc?")
    
    If Len(sFname) > 0 Then
        Do
            Set WDoc = WApp.Documents.Open(sPath & sFname)
            WApp.ActiveDocument.Select
            
                With WApp.Selection.Find
                .Text = str2Find
                .Forward = True
                .Execute
                
                If .Found = True Then
                .Parent.Expand Unit:=wdSentence
                myData = WApp.Selection.Text
                myline = WApp.Selection.Range.Information(wdFirstCharacterLineNumber)
                ExR.Offset(, 1) = sFname
                ExR.Offset(, 2) = myline
                ExR.Offset(, 3) = myData
                WDoc.Close
                WApp.Quit
                MsgBox "완료"
                Exit Sub
                End If
                End With
        WDoc.Close
        sFname = Dir
        Loop Until Len(sFname) = 0
        
    End If

MsgBox "찾는 단어가 있는 파일이 없습니다"

    
End Sub

 

해당단어가 속해 있는 문장을 선택하는 구문인

.Parent.Expand Unit:=wdSentence 이 부분에서 자꾸 에러가 나서 고생했는데, 

Microsoft Word Object Library를 참조하니까 해결되었다.