다수의 엑셀파일에서 특정 단어 추출하는 매크로

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("감리자동화도구-단어추출.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("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

Sub 매크로1()
'
' 매크로1 매크로
'

'

End Sub
Sub 매크로2()
'
' 매크로2 매크로
'

'

End Sub