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

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

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

    

    Cells(1, 1) = "단어:"

    Cells(1, 3) = "을"

    Cells(1, 5) = "행"

    Cells(1, 7) = "열부터"

    Cells(1, 10) = "행"

    Cells(1, 12) = "열까지에서 찾기"

    

    

    Range("B1,D1,F1,I1,K1").Select

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

    With Selection.Borders(xlEdgeLeft)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeTop)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeBottom)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlEdgeRight)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlInsideVertical)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Borders(xlInsideHorizontal)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlThin

    End With

    With Selection.Interior

        .Pattern = xlSolid

        .PatternColorIndex = xlAutomatic

        .Color = 65535

        .TintAndShade = 0

        .PatternTintAndShade = 0

    End With

    Cells(8, 5) = "*.xls*"

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

    Set fdFolder = Application.FileDialog(msoFileDialogFolderPicker)

    With fdFolder

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

        If .Show = -1 Then

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

            folderspec = Range("D8").Value

            SearchSubFolders2

        End If

    End With

    Cells(8, 6) = "=counta(C9:C2000)"

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     '   초기화

    

    '처리할 파일의 갯수\

    orgWorkBookName = ActiveWorkbook.Name

    

    fileCnt = Cells(8, 6).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(orgWorkBookName).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(orgWorkBookName).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("D8").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("E8").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