엑셀에서 단어 추출하는 매크로

엑셀의 여러 파일을 열어 단어를 추출하는 매크로입니다. 

Option Compare Text

Sub StartMacro()

'박규효 2011년 03월 22일 제작

End Sub

Sub getFolder()

    '각종 변수 선언

    Dim strPath As String

    Dim strNm As String

    Dim i As Integer

    

    Dim fdFolder As FileDialog

    Dim lngCount As Long

    

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

    Sheets("fileSheet").Activate

    ActiveSheet.Range("d3").Value = ""

    ActiveSheet.Range("b9:f10000").Value = ""

    ActiveSheet.Cells(8, 6).Value = 9

    

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

    Set fdFolder = Application.FileDialog(msoFileDialogFolderPicker)

    With fdFolder

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

        If .Show = -1 Then

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

            folderspec = Range("d3").Value

            SearchSubFolders2

        End If

    End With

    

End Sub

  

Sub extractWord()

'

    

    '변수 선언 integer 는 32767 까지의 값만을 지원한다.

    Dim i As Integer

    Dim maxVal As Integer

    Dim startVal As Integer

    Dim nextVal As Integer

    Dim fileCnt As Integer           ' 파일의 수

    Dim sheetCnt As Integer     ' 파일의 시트 수

    Dim sNo As Integer          ' 처리한 시트 수

    Dim cellPnt As Integer

    Dim rowCnt As Integer

    Dim colCnt As Integer

    

    Dim f_name As String        '읽고자 하는 파일명

    Dim t_name As String        '매핑정의서에 기재된 소스테이블명

    Dim file_name As String      '파일명 전체

    Dim targetWord As String   '찾고자하는 단어명

    Dim cellVal As String       '단어를 찾은 셀의 내용

    

    '변수 기본값 할당

    i = 9           ' 첫 파일명이 세번째 줄에 있음.

    cellPnt = 2     ' 두번째 줄부터 써야 함.

    maxVal = 0      '   초기화

    startVal = 1    ' 파일 찾기 시작

    nextVal = 0     '   초기화

    

    '처리할 파일의 갯수

    fileCnt = Sheets("fileSheet").Cells(8, 5).Value

    targetWord = Sheets("fileSheet").Cells(1, 2).Value

    srVal = Sheets("fileSheet").Cells(1, 4).Value

    scVal = Sheets("fileSheet").Cells(1, 6).Value

    erVal = Sheets("fileSheet").Cells(1, 9).Value

    ecVal = Sheets("fileSheet").Cells(1, 11).Value

        

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

    

    Sheets.Add after:=Sheets(1)

    Sheets(2).Name = "단어추출-" & Date & Hour(Time) & Minute(Time) & Second(Time)

    

    Sheets(2).Activate

    Cells(1, 1).Value = "번호"

    Cells(1, 2).Value = "폴더명"

    Columns("b:b").ColumnWidth = 20

'    Rows("8:8").RowHeight = 35.25

    Cells(1, 3).Value = "파일명"

    Columns("c:c").ColumnWidth = 40

    Cells(1, 4).Value = "시트명"

    Columns("d:d").ColumnWidth = 20

    Cells(1, 5).Value = "셀위치"

    Cells(1, 6).Value = "조회결과"

    Columns("f:f").ColumnWidth = 20

    Range(Cells(1, 1), Cells(1, 7)).Select

    Selection.AutoFilter

    

    '반복하며 파일 처리 함

    Do While i < fileCnt + 9

        sNo = 1

'        ' 파일열기

        d_name = Sheets("fileSheet").Cells(i, 2).Value

        f_name = Sheets("fileSheet").Cells(i, 3).Value

        file_name = d_name + "\" + f_name

    

        Dim fs, f, s

        Set fs = CreateObject("Scripting.FileSystemObject")

        Set f = fs.GetFile(file_name)

        

            Workbooks.Open Filename:=file_name

            

            

            sheetCnt = ActiveWorkbook.Sheets.Count

            

    

    '        '시트 수 만큼 반복하며 확인할 것

            

            Do While sNo <= sheetCnt

               

                Workbooks(f_name).Activate

                If Sheets(sNo).Visible = False Then

                Else

                    Sheets(sNo).Select

                    sName = Sheets(sNo).Name

                    

                    With Worksheets(sNo).Range(Cells(srVal, scVal), Cells(erVal, ecVal))

                        Set c = .Find(targetWord, LookIn:=xlValues)

                        If Not c Is Nothing Then

                            firstAddress = c.Address

                            Do

                                cellVal = c.Value

                                '확인된 시트명을 결과시트에 적기

                                Workbooks("감리자동화도구-단어추출.xls").Activate

                                Sheets(2).Activate

                                ActiveSheet.Cells(cellPnt, 2).Select

                                ActiveSheet.Cells(cellPnt, 1).Value = Str(i - 8) + "/" + Str(fileCnt)

                                ActiveSheet.Cells(cellPnt, 2).Value = d_name

                                ActiveSheet.Cells(cellPnt, 3).Value = f_name

                                ActiveSheet.Cells(cellPnt, 4).Value = sName

                                anchorinfo = file_name + "#" + sName + "!" + c.Address

                                

                                ActiveSheet.Hyperlinks.Add anchor:=Cells(cellPnt, 5), Address:=anchorinfo, TextToDisplay:=c.Address

                                

                                ActiveSheet.Cells(cellPnt, 6).Value = cellVal

                                

                                cellPnt = cellPnt + 1

                                

                                Set c = .FindNext(c)

                                If c Is Nothing Then

                                    Exit Do

                                End If

                                

                            Loop While Not c Is Nothing And c.Address <> firstAddress

                       

                        Else

                            '확인된 시트명을 결과시트에 적기

                            Workbooks("감리자동화도구-단어추출.xls").Activate

                            Sheets(2).Activate

    '                        ActiveSheet.Cells(cellPnt, 2).Select

                            ActiveSheet.Cells(cellPnt, 1).Value = Str(i - 8) + "/" + Str(fileCnt)

                            ActiveSheet.Cells(cellPnt, 2).Value = d_name

                            ActiveSheet.Cells(cellPnt, 3).Value = f_name

                            ActiveSheet.Cells(cellPnt, 4).Value = sName

                            ActiveSheet.Cells(cellPnt, 5).Value = "없음"

                            ActiveSheet.Cells(cellPnt, 6).Value = "없음"

                            cellPnt = cellPnt + 1

                        End If

                    End With

                End If

                Cells(cellPnt, 1).Select

                sNo = sNo + 1

            Loop

         

            '파일 닫기

            Application.DisplayAlerts = False

            Workbooks(f_name).Close SaveChanges:=False

            

         i = i + 1

            

    Loop

    Range("a1:k1000").Select

    With Selection.Font

        .Name = "맑은 고딕"

        .Size = 10

    End With

    

    MsgBox ("작업을 완료하였습니다.")

    

End Sub

 

Sub SearchSubFolders2()

    Dim result As String

    Dim strFilter As String

    Dim Msg As String

    Dim strDir As String

    Dim r As Long

    

    strDir = Range("d3").Value

    If strDir = "" Then

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

        Exit Sub

    End If

   

    r = 8

    

    Sheets(1).Cells(r, 2) = "폴더명"

    Sheets(1).Cells(r, 3) = "파일명"

    Sheets(2).Range("a1:d1").Font.Name = "Arial"

    r = r + 1

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

  

    strFilter = Range("d4").Value

    

    result = sRetrieve(strDir, strFilter, r)

   

End Sub

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

   

    Set fs = CreateObject("Scripting.FileSystemObject")

    Set dDirs = fs.getFolder(sPath)

   

    For Each dDir In dDirs.SubFolders

        sRetrieve = sRetrieve(dDir.Path, strFilter, r) ' Here is the recursion

    Next

   

    For Each fFile In dDirs.Files

        If fFile.Name Like "~*" Then

        ElseIf fFile.Name Like strFilter Then

            Sheets(1).Cells(r, 2) = fFile.parentfolder.Path

            Sheets(1).Cells(r, 3) = fFile.Name

            r = r + 1

        End If

    Next

    

    Set fs = Nothing

End Function