무성의한 블로그

문서를 실행하시면 컨텐츠 사용여부를 묻는 메세지가 나옵니다.
반드시 허용하셔야 합니다.

1. 폴더 가져오기로 해당 폴더의 워드파일들을 가져옵니다.
너무 많으면 오류가 발생할 수 있으므로 적당한 수로 나누어서 하시기 바랍니다.
한 50개 정도는 문제가 없었던거 같습니다.

2. 문서 중에 검색 대상이 아닌 문서는 목록에서 선택하신 후 리스트 1건 삭제 버튼을 클릭하시면 됩니다.

3. 검색단어 에 검색할 단어를 입력하시고 하단의 자료추출 버튼을 클릭하시면됩니다.

4. 검색조건은 몇개의 파일을 하나의 결과문서에 나타낼지를 정하는 것입니다.
예를 들어 50개 문서에 검색조건 10을 선택하면 결과문서는 5개가 나옵니다.

오류가 발생하는 경우가 있습니다. 이 때는 매크로 창에서 도구->참조 창을 엽니다.
사용가능한 참조 들 중에 앞에 '누락-'으로 시작하는 항목들이 있는데 이 것들의 체크박스를 풀어주시면 정상적으로 수행될 것입니다.

한번 써보시면 쉽게 될 겁니다. 

--------------------------------------------

문서 검색.docm

Private Sub CommandButton1_Click()

getFolder

End Sub

Private Sub CommandButton2_Click()

    getSentense

End Sub

Sub goCopy()

    varCnt = ListBox1.ListCount

    fileCnt = TextBox2.Value

    i = 0

    Do While i < varCnt

        fileNum = i Mod fileCnt

        If fileNum = 0 Then

            If i = 0 Then

            Else

                ActiveDocument.Close SaveChanges:=wdSaveChanges

            End If

            ChangeFileOpenDirectory TextBox1.Text

            Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0

            newFileName = "복사대상" & i + 1 & "-" & i + fileCnt & Date & Hour(Time) & Minute(Time) & Second(Time) & ".docx"

            ActiveDocument.SaveAs FileName:=newFileName

        End If

        fileVal = ListBox1.List(i)

        chkLen = InStr(fileVal, "-")

        fileVal = Left(fileVal, chkLen - 1)

        '복사할 대상을 열어 복사함

        Documents.Open FileName:=fileVal, ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""

        Selection.WholeStory

        Selection.Copy

        Documents(fileVal).Close

        '새 파일을 저장한 위치로 옮김.

        ChangeFileOpenDirectory TextBox1.Text

        Documents(newFileName).Activate

        Documents(newFileName).Select

        '새파일의 맨 뒤로 이동함.

        Selection.EndKey Unit:=wdStory

        '붙혀넣기 전에 링크를 추가함

        ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:= _

            fileVal, SubAddress:="", ScreenTip:="", TextToDisplay:=fileVal

        '붙여 넣기함.

        Selection.PasteAndFormat (wdPasteDefault)

        ' 맨 뒤로 이동하여 다음 파일 붙여넣기 준비함

        Selection.EndKey Unit:=wdStory

        '다음 페이지로 넘어가기 ctr+enter

        Selection.InsertBreak Type:=wdPageBreak

        i = i + 1

    Loop

    ActiveDocument.Save

End Sub

Sub getFolder()

    '각종 변수 선언

    Dim strPath As String

    Dim strNm As String

    Dim i As Integer

    Dim fdFolder As FileDialog

    Dim lngCount As Long

    ' 현재 있는 데이터를 모두 삭제해야 함.

    ListBox1.Clear

    '서브폴더의 내용을 가져옴

    Set fdFolder = Application.FileDialog(msoFileDialogFolderPicker)

    With fdFolder

        .Title = "검색할 폴더를 선택 하세요"

        If .Show = -1 Then

            folderspec = .SelectedItems(1)  '선택한 폴더명을 A3 셀에 저장

            getSubFolder (folderspec)

        End If

    End With

    TextBox1.Text = folderspec

    TextBox11.Text = ListBox1.ListCount

    TextBox2.Text = ListBox1.ListCount

End Sub

Sub getSubFolder(folderspec)

    Dim result As String

    Dim strFilter As String

    Dim Msg As String

    Dim strDir As String

    Dim r As Long

    strDir = folderspec

    If strDir = "" Then

        MsgBox (" 선택된 폴더가 없습니다. 폴더를 선택하세요.")

        Exit Sub

    End If

    r = 1

    r = r + 1

    If Trim(Right(strDir, 1)) <> "\" Then strDir = strDir & "\"

    strFilter = "*.doc*"

    result = sRetrieve(strDir, strFilter, r)

End Sub

Private Function sRetrieve(sPath As String, strFilter As String, r As Long) As String

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set dDirs = fs.getFolder(sPath)

    For Each dDir In dDirs.SubFolders

        sRetrieve = sRetrieve(dDir.Path, strFilter, r)

    Next

    For Each fFile In dDirs.Files

        If fFile.Name Like strFilter Then

            If Left(fFile.Name, 1) = "~" Then

            Else

                ListBox1.AddItem fFile.Path & "-" & fFile.Size

            End If

            r = r + 1

        End If

    Next

    Set fs = Nothing

End Function

Private Sub CommandButton3_Click()

    'Ensure ListBox contains list items

    If ListBox1.ListCount >= 1 Then

        'If no selection, choose last list item.

        If ListBox1.ListIndex = -1 Then

            ListBox1.ListIndex = ListBox1.ListCount - 1

        End If

        ListBox1.RemoveItem (ListBox1.ListIndex)

    End If

    TextBox11 = ListBox1.ListCount

End Sub

Private Sub ListBox1_Click()

    TextBox3.Text = ListBox1

End Sub

Private Sub ListBox1_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

    selName = ListBox1

    docNameLen = Len(selName)

    chkLen = InStr(selName, "-")

    selName = Left(selName, chkLen - 1)

    Documents.Open (selName)

End Sub

Private Sub ListBox2_DblClick(ByVal Cancel As MSForms.ReturnBoolean)

    copyName = ListBox2

    Documents.Open (copyName)

End Sub

Sub getSentense()

    varCnt = ListBox1.ListCount

    fileCnt = TextBox2.Value

    targetText = TextBox4.Value

    i = 0

    Do While i < varCnt

        fileNum = i Mod fileCnt

        If fileNum = 0 Then

            If i = 0 Then

            Else

                ActiveDocument.Close SaveChanges:=wdSaveChanges

            End If

            ChangeFileOpenDirectory TextBox1.Text

            Documents.Add Template:="Normal", NewTemplate:=False, DocumentType:=0

            newFileName = "복사대상" & TextBox2.Text & i + 1 & "-" & i + fileCnt & Date & Hour(Time) & Minute(Time) & Second(Time) & ".docx"

            ActiveDocument.SaveAs FileName:=newFileName

        End If

        fileVal = ListBox1.List(i)

        chkLen = InStr(fileVal, "-")

        fileVal = Left(fileVal, chkLen - 1)

        sendVal = newFileName & "*" & fileVal

        '복사할 대상을 열어 복사함

        Documents.Open FileName:=fileVal, ConfirmConversions:=False, ReadOnly:=False, AddToRecentFiles:=False, PasswordDocument:="", PasswordTemplate:="", Revert:=False, WritePasswordDocument:="", WritePasswordTemplate:="", Format:=wdOpenFormatAuto, XMLTransform:=""

'자료찾아복사하는 함수 호출함.

chkexeval = True

    Do While chkexeval = True

        Selection.Find.ClearFormatting

        With Selection.Find

            .Text = targetText

            .Replacement.Text = ""

            .Forward = True

            .Wrap = wdFindStop

            .Format = False

            .MatchCase = False

            .MatchWholeWord = False

            .MatchByte = False

            .CorrectHangulEndings = True

            .HanjaPhoneticHangul = False

            .MatchWildcards = False

            .MatchSoundsLike = False

            .MatchAllWordForms = False

        End With

        chkexeval = Selection.Find.Execute

        If chkexeval = True Then

            Selection.MoveLeft Unit:=wdCharacter, Count:=1, Extend:=wdExtend

'            Selection.MoveDown Unit:=wdLine, Count:=1, Extend:=wdExtend

            Selection.MoveRight Unit:=wdWord, Count:=7, Extend:=wdExtend

            Selection.Copy

            Selection.MoveRight Unit:=wdCharacter, Count:=1

        End If

            '새 파일을 저장한 위치로 옮김.

            ChangeFileOpenDirectory TextBox1.Text

            Documents(newFileName).Activate

            Documents(newFileName).Select

            '새파일의 맨 뒤로 이동함.

            Selection.EndKey Unit:=wdStory

            Selection.TypeParagraph

        '붙혀넣기 전에 링크를 추가함

        ActiveDocument.Hyperlinks.Add Anchor:=Selection.Range, Address:= _

            fileVal, SubAddress:="", ScreenTip:="", TextToDisplay:=fileVal

        '붙여 넣기함.

        Selection.PasteAndFormat (wdFormatPlainText)

        Selection.TypeText (vbTab)

        Selection.TypeText (chkexeval)

        Selection.TypeText (vbTab)

        Selection.EndKey Unit:=wdStory

        Selection.TypeParagraph

        Documents(fileVal).Activate

    Loop

        Documents(fileVal).Close

        i = i + 1

    Loop

    ActiveDocument.Save

End Sub

Sub goCopyTitle(sendVal)

        txtLen = Len(sendVal)

End Sub