무성의한 블로그

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

Sub getFolder()

    Rows("1:2").Select

    Selection.RowHeight = 16.5

    Columns("a:a").ColumnWidth = 9

    Columns("B:B").ColumnWidth = 45

    ActiveSheet.Shapes("Button 2").Left = 10

    ActiveSheet.Shapes("Button 2").Top = 32

    ActiveSheet.Shapes("Button 2").Width = 300

    ActiveSheet.Shapes("Button 2").Height = 17

    ActiveSheet.Shapes("Button 1").Left = 10

    ActiveSheet.Shapes("Button 1").Top = 50

    ActiveSheet.Shapes("Button 1").Width = 150

    ActiveSheet.Shapes("Button 1").Height = 30

    ActiveSheet.Shapes("Button 3").Left = 160

    ActiveSheet.Shapes("Button 3").Top = 50

    ActiveSheet.Shapes("Button 3").Width = 150

    ActiveSheet.Shapes("Button 3").Height = 30

'필터와 디렉토리 내용 지우기

    Range("C1:C8").Select

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

    Selection.Borders(xlEdgeLeft).LineStyle = xlNone

    Selection.Borders(xlEdgeTop).LineStyle = xlNone

    Selection.Borders(xlEdgeBottom).LineStyle = xlNone

    Selection.Borders(xlEdgeRight).LineStyle = xlNone

    Selection.Borders(xlInsideVertical).LineStyle = xlNone

    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

    With Selection.Interior

        .Pattern = xlNone

        .TintAndShade = 0

        .PatternTintAndShade = 0

    End With

    Range("c3").Select

    Selection.ClearContents

'필터와 디렉토리 새로 그리기

    Range("C3:C4").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(1, 1) = "제작자"

Cells(1, 2) = "kca박규효"

    '각종 변수 선언

    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("c3").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("c3") = .SelectedItems(1) '선택한 폴더명을 A3 셀에 저장

            folderspec = Range("c3").Value

        End If

    End With

End Sub

Sub getSubFolderInHere()

    Rows("1:2").Select

    Selection.RowHeight = 16.5

    Columns("a:a").ColumnWidth = 9

    Columns("B:B").ColumnWidth = 45

    ActiveSheet.Shapes("Button 2").Left = 10

    ActiveSheet.Shapes("Button 2").Top = 32

    ActiveSheet.Shapes("Button 2").Width = 300

    ActiveSheet.Shapes("Button 2").Height = 17

    ActiveSheet.Shapes("Button 1").Left = 10

    ActiveSheet.Shapes("Button 1").Top = 50

    ActiveSheet.Shapes("Button 1").Width = 150

    ActiveSheet.Shapes("Button 1").Height = 30

    ActiveSheet.Shapes("Button 3").Left = 160

    ActiveSheet.Shapes("Button 3").Top = 50

    ActiveSheet.Shapes("Button 3").Width = 150

    ActiveSheet.Shapes("Button 3").Height = 30

'필터와 디렉토리 내용 지우기

    Range("C1:C8").Select

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

    Selection.Borders(xlEdgeLeft).LineStyle = xlNone

    Selection.Borders(xlEdgeTop).LineStyle = xlNone

    Selection.Borders(xlEdgeBottom).LineStyle = xlNone

    Selection.Borders(xlEdgeRight).LineStyle = xlNone

    Selection.Borders(xlInsideVertical).LineStyle = xlNone

    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

    With Selection.Interior

        .Pattern = xlNone

        .TintAndShade = 0

        .PatternTintAndShade = 0

    End With

'필터와 디렉토리 새로 그리기

    Range("C3:C4").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(1, 1) = "제작자"

Cells(1, 2) = "kca박규효"

    Dim result As String

    Dim strFilter As String

    Dim Msg As String

    Dim strDir As String

    Dim r As Long

    strDir = Range("c3").Value

    strFileType = Range("c4").Value

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

    If strDir = "" Then

        getFolder

        Exit Sub

    ElseIf strFileType = "" Then

        strFileType = "*"

    End If

    r = 9

    Sheets(1).Cells(7, 1) = "검색폴더"

    Sheets(1).Cells(7, 2) = strDir

    Sheets(1).Cells(8, 1) = "검색단어"

    Sheets(1).Cells(8, 2) = strFileType

    Sheets(1).Cells(r, 1) = "번호"

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

    Sheets(1).Cells(r, 2).ColumnWidth = 45

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

    Sheets(1).Cells(r, 3).ColumnWidth = 45

    Sheets(1).Cells(r, 4) = "크기"

    Sheets(1).Cells(r, 5) = "파일타입"

    Sheets(1).Cells(r, 6) = "작성일"

    Sheets(1).Cells(r, 7) = "수정일"

    Sheets(1).Range(Cells(r, 1), Cells(r, 6)).Select

    Selection.AutoFilter

    Cells(10, 2).Select

    ActiveWindow.FreezePanes = True

    Sheets(1).Range("a10", "g1000").Select

    Selection.ClearContents

    r = r + 1

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

    strFilter = "*" & Sheets(1).Range("c4").Value & "*"

    result = sRetrieveInHere(strDir, strFilter, r)

    Sheets(1).Range("a1:g1000").Font.Name = "Arial"

    Sheets(1).Range("a1:g1000").Font.Size = 9

    Sheets(1).Range(Cells(4, 2), Cells(r, 2)).Select

    Selection.Replace What:=Cells(1, 2), Replacement:="", LookAt:=xlPart, _

        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

        ReplaceFormat:=False

    Selection.Font.Underline = xlUnderlineStyleNone

    Sheets(1).Cells(4, 2).Select

End Sub

Sub getSubFolderInNext()

    Rows("1:2").Select

    Selection.RowHeight = 16.5

    Columns("a:a").ColumnWidth = 9

    Columns("B:B").ColumnWidth = 45

    ActiveSheet.Shapes("Button 2").Left = 10

    ActiveSheet.Shapes("Button 2").Top = 32

    ActiveSheet.Shapes("Button 2").Width = 300

    ActiveSheet.Shapes("Button 2").Height = 17

    ActiveSheet.Shapes("Button 1").Left = 10

    ActiveSheet.Shapes("Button 1").Top = 50

    ActiveSheet.Shapes("Button 1").Width = 150

    ActiveSheet.Shapes("Button 1").Height = 30

    ActiveSheet.Shapes("Button 3").Left = 160

    ActiveSheet.Shapes("Button 3").Top = 50

    ActiveSheet.Shapes("Button 3").Width = 150

    ActiveSheet.Shapes("Button 3").Height = 30

'필터와 디렉토리 내용 지우기

    Range("C1:C8").Select

    Selection.Borders(xlDiagonalDown).LineStyle = xlNone

    Selection.Borders(xlDiagonalUp).LineStyle = xlNone

    Selection.Borders(xlEdgeLeft).LineStyle = xlNone

    Selection.Borders(xlEdgeTop).LineStyle = xlNone

    Selection.Borders(xlEdgeBottom).LineStyle = xlNone

    Selection.Borders(xlEdgeRight).LineStyle = xlNone

    Selection.Borders(xlInsideVertical).LineStyle = xlNone

    Selection.Borders(xlInsideHorizontal).LineStyle = xlNone

    With Selection.Interior

        .Pattern = xlNone

        .TintAndShade = 0

        .PatternTintAndShade = 0

    End With

'필터와 디렉토리 새로 그리기

    Range("C3:C4").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(1, 1) = "제작자"

Cells(1, 2) = "kca박규효"

    Dim result As String

    Dim strFilter As String

    Dim Msg As String

    Dim strDir As String

    Dim r As Long

    strDir = Range("c3").Value

    strFileType = Range("c4").Value

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

    If strDir = "" Then

        getFolder

        Exit Sub

    ElseIf strFileType = "" Then

        strFileType = "*"

    End If

    r = 3

    Sheets.Add after:=Sheets(1)

    Sheets(2).Name = Date & Hour(Time) & Minute(Time) & Second(Time)

    Sheets(2).Cells(7, 1) = "검색폴더"

    Sheets(2).Cells(7, 2) = strDir

    Sheets(2).Cells(8, 1) = "검색단어"

    Sheets(2).Cells(8, 2) = strFileType

    Sheets(2).Cells(r, 1) = "번호"

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

    Sheets(2).Cells(r, 2).ColumnWidth = 45

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

    Sheets(2).Cells(r, 3).ColumnWidth = 45

    Sheets(2).Cells(r, 4) = "크기"

    Sheets(2).Cells(r, 5) = "파일타입"

    Sheets(2).Cells(r, 6) = "작성일"

    Sheets(2).Cells(r, 7) = "수정일"

    Sheets(2).Range(Cells(r, 1), Cells(r, 6)).Select

    Selection.AutoFilter

    Cells(4, 2).Select

    ActiveWindow.FreezePanes = True

    Sheets(2).Range("a4", "g1000").Select

    Selection.ClearContents

    r = r + 1

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

    strFilter = "*" & Sheets(1).Range("c4").Value & "*"

    result = sRetrieveInNext(strDir, strFilter, r)

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

    Sheets(2).Range("a1:g1000").Font.Size = 9

    Sheets(2).Range(Cells(4, 2), Cells(r, 2)).Select

    Selection.Replace What:=Cells(1, 2), Replacement:="", LookAt:=xlPart, _

        SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _

        ReplaceFormat:=False

    Sheets(2).Cells(4, 2).Select

End Sub

Private Function sRetrieveInNext(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

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

    Next

    For Each fFile In dDirs.Files

        If fFile.Name Like "~*" Then

        ElseIf fFile.Name Like strFilter Then

            Sheets(2).Cells(r, 1) = r - 3

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

            anchorinfo = fFile.parentfolder.Path + "\" + fFile.Name

            ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, 3), Address:=anchorinfo, TextToDisplay:=fFile.Name

            Sheets(2).Cells(r, 4) = fFile.Size

            Sheets(2).Cells(r, 5) = fFile.Type

            Sheets(2).Cells(r, 6) = Left(fFile.datecreated, 10)

            Sheets(2).Cells(r, 7) = Left(fFile.DateLastModified, 10)

           r = r + 1

        End If

    Next

    Set fs = Nothing

End Function

Private Function sRetrieveInHere(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

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

    Next

    For Each fFile In dDirs.Files

        If fFile.Name Like "~*" Then

        ElseIf fFile.Name Like strFilter Then

            Sheets(1).Cells(r, 1) = r - 9

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

            anchorinfo = fFile.parentfolder.Path + "\" + fFile.Name

            ActiveSheet.Hyperlinks.Add Anchor:=Cells(r, 3), Address:=anchorinfo, TextToDisplay:=fFile.Name

            Sheets(1).Cells(r, 4) = fFile.Size

            Sheets(1).Cells(r, 5) = fFile.Type

            Sheets(1).Cells(r, 6) = Left(fFile.datecreated, 10)

            Sheets(1).Cells(r, 7) = Left(fFile.DateLastModified, 10)

           r = r + 1

        End If

    Next

    Set fs = Nothing

End Function

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

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

특별한 것은 없는데 중간에 하이퍼링크 거는 방법을 참고하시라고 올려봅니다.

Sub extractWord()

'

' Macro1 Macro

'

    '변수 선언 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     '   초기화

    '처리할 시트의 위치

    startSht = Cells(1, 2).Value

    jobName = Cells(2, 2).Value

    sColVal = Cells(1, 4).Value

    sRowVal = Cells(1, 6).Value

    eColVal = Cells(2, 4).Value

    eRowVal = Cells(2, 6).Value

    titleVal = Cells(2, 10).Value

    ' 시트를 새로 만든다.

    orgBookName = ActiveWorkbook.Name

    Sheets.Add after:=Sheets(1)

    Sheets(2).Name = jobName & Date & Hour(Time) & Minute(Time) & Second(Time)

    Cells(1, 4).Activate

    ActiveCell.FormulaR1C1 = "=COUNTA(R[1]C:R[3000]C)"

    '반복하며 파일 처리 함

        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

                If sNo < startSht Then

                Else

                    Workbooks(f_name).Activate

                    If Sheets(sNo).Visible = xlSheetVisible Then

                        Sheets(sNo).Select

                        sName = Sheets(sNo).Name

                        If sNo = startSht Then

                            Range(Cells(sColVal - titleVal, sRowVal), Cells(eColVal, eRowVal)).Select

                        Else

                            Range(Cells(sColVal, sRowVal), Cells(eColVal, eRowVal)).Select

                        End If

                        Selection.Copy

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

                        Workbooks(orgBookName).Activate

                        If sNo = startSht Then

                            ActiveSheet.Cells(cellPnt + titleVal, 1).Value = sNo

                            anchorinfo = file_name + "#'" + sName + "'!A1"

                            ActiveSheet.Hyperlinks.Add Anchor:=Cells(cellPnt + titleVal, 3), Address:=anchorinfo, TextToDisplay:=sName

                        Else

                            ActiveSheet.Cells(cellPnt, 1).Value = sNo

                            anchorinfo = file_name + "#'" + sName + "'!A1"

                            ActiveSheet.Hyperlinks.Add Anchor:=Cells(cellPnt, 3), Address:=anchorinfo, TextToDisplay:=sName

                        End If

                        Cells(cellPnt, 4).Select

                        ActiveSheet.Paste

                        lastRow = Cells(1, 4).Value

                        If sNo = startSht Then

                            ActiveSheet.Cells(cellPnt + titleVal, 2).Value = lastRow - (titleVal)

                            Range(Cells(cellPnt + titleVal, 1), Cells(cellPnt + titleVal, 3)).Copy

                            Range(Cells(cellPnt + titleVal + 1, 1), Cells(lastRow - cellPnt + 3, 3)).Select

                            ActiveSheet.Paste

                        Else

                            pgmCnt = lastRow - cellPnt + 2

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

                            Range(Cells(cellPnt, 1), Cells(cellPnt, 3)).Copy

                            Range(Cells(cellPnt + 1, 1), Cells(cellPnt + pgmCnt - 1, 3)).Select

                            ActiveSheet.Paste

                        End If

                        cellPnt = lastRow + 2

                    End If

                End If

                sNo = sNo + 1

            Loop

            '파일 닫기

            Application.DisplayAlerts = False

            Workbooks(f_name).Close SaveChanges:=False

         i = i + 1

    Cells(titleVal + 1, 1).Value = "시트번호"

    Cells(titleVal + 1, 2).Value = "프로그램목록 수"

    Cells(titleVal + 1, 3).Value = "시트명"

    Rows("2:3000").Select

    Selection.RowHeight = 16.5

    Cells(titleVal + 2, 4).Select

    ActiveWindow.FreezePanes = True

    Sheets(2).Range(Cells(titleVal + 1, 1), Cells(titleVal + 1, 38)).Select

    Selection.AutoFilter

    Cells(1, 7).Select

'    ActiveWorkbook.SaveAs Filename:="c:\temp\test.xlsx", FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

    ActiveWorkbook.Save

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

End Sub

외부에서 하나의 텍스트 파일로 제공된 파일을 정해진 크기에 맞춰 자르는 매크로 소스입니다. 

파일이 없으면 확인하기도 어렵겠지만 처리하는 방식을 참조하시기 바랍니다. 

첫번 째 시트에 텍스트 파일을 옮겨놓습니다. 텍스트파일은 sam파일이나 cdr 데이터 등 일겁니다.

두번째 시트에 작업을합니다. 

시작은 두번째 시트에서 시작합니다. 

Sub chopText()

    Cells(4, 3).Select

    ActiveCell.FormulaR1C1 = "=COUNTA(R[3]C:R[300]C)"

    colCnt = Cells(4, 3)

    '테이블 정의 읽어오기

    Range(Cells(6, 3), Cells(colCnt + 6, 3)).Select

    Selection.Copy

    Cells(3, 12).Select

    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

    Range(Cells(6, 6), Cells(colCnt + 6, 8)).Select

    Selection.Copy

    Cells(4, 12).Select

    Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:=False, Transpose:=True

    '컨텐츠 복사해 오기

    Sheets("데이터").Select

    Range(Cells(1, 1), Cells(100000, 10)).Select

    Selection.Copy

    Sheets("수행").Select

    Cells(7, 13).Select

    ActiveSheet.Paste

    Cells(2, 12).Select

    ActiveCell.FormulaR1C1 = "=COUNTA(R[5]C:R[100000]C)"

    txtCnt = Cells(2, 12)

    '7번에 있는 레코드는 헤더

    t = 8

    Do While t < txtCnt + 6

        chopTxt = Cells(t, 12)

            i = 13

            Do While i < colCnt + 14

                chopLen = Cells(5, i)

                Cells(t, i + 1).Select

                Selection.NumberFormatLocal = "@"

                Cells(t, i + 1) = Mid(Cells(t, i), chopLen + 1)

                Cells(t, i).Select

                Selection.NumberFormatLocal = "@"

                Cells(t, i) = Mid(Cells(t, i), 1, chopLen)

                i = i + 1

            Loop

        t = t + 1

    Loop

 Cells(6, 12).Select

End Sub

Sub clearPage()

    Range(Cells(7, 1), Cells(300, 10)).Clear

    Range(Cells(1, 11), Cells(1000, 400)).Clear

End Sub

엑셀 매크로를 작성하는 동안 상당히 거슬렸던 것이 autofilter다.

selection.autofilter라고하면 자동으로 필터가 걸리기 때문에 설정도 쉽고

기왕에 설정된 시트에 selection.autofilter를 실행하면 자동으로 해제되기 때문에 해제도 쉽다.

그러나 있으면 없애고 없으면 생기게 하기가 쉽지 않았다. 

 autofilter는 셀 단위로 걸리는데 필터의 설정 여부를 확인하는 것은 시트 단위이다.

따라서 시트의 autofiltermode를 점검해서 true면 넘어가고 false면 설정하면 된다. 

        ' 시트에 자동 필터가 설정되어 있는지 확인한다. 

        afChk = Worksheets("컬럼비교").AutoFilterMode

' 만약 설정되어 있으면

        If afChk = True Then

' 내가 원하는 필터가 아닐 수 있으므로 해제하고 내가 원하는 필터로 교체한다. 

            afChk = Selection.AutoFilter

            Range("A3:K3").Select

            afChk = Selection.AutoFilter

        Else

' 내가 원하는 필터를 설정한다. 

            Range("A3:K3").Select

            afChk = Selection.AutoFilter

        End If

Sub goCalcMoney()

'관세율

    tradeTaxRate = Cells(2, 2)

    addTaxRate = Cells(3, 2)

    moneyRate = Cells(4, 2)

    Range(Cells(13, 2), Cells(24, 7)).Value = 0

    k = 2

    Do While k < 8

        goodsMoney = Cells(8, k)

        InType = Cells(6, k)

        If goodsMoney < 1 Or goodsMoney = "" Then

        Else

            transFee = Cells(9, k)

            taxFee = Cells(10, k)

            weightAll = Cells(11, k)

            '1차 합계

            totalDallor = goodsMoney + transFee + taxFee

            sumKoreaWon = totalDallor * moneyRate

            Cells(13, k) = sumKoreaWon

            '과세운임

            i = 2

            Do While i < 999

                startWeight = Cells(i, 16)

                If startWeight < weightAll Then

                    i = i + 1

                Else

                    If sumKoreaWon > 200000 Then

                        transTaxFee = Cells(i - 1, 19).Value

                        Cells(14, k).Value = transTaxFee

                    Else

                        transTaxFee = Cells(i - 1, 18).Value

                        Cells(14, k).Value = transTaxFee

                    End If

                    i = 999

                End If

            Loop

            '과세기준

            standardTax = sumKoreaWon + transTaxFee

            Cells(15, k) = standardTax

            '관세

            If standardTax < 150000 Or (goodsMoney < 200 And InType = "목록") Then

                afterTax = sumKoreaWon

                afterAddTax = sumKoreaWon

                tradeType = "비과세"

            Else

                afterTax = standardTax * (1 + (tradeTaxRate / 100))

                afterAddTax = afterTax * (1 + (addTaxRate) / 100)

                tradeType = ""

            End If

            Cells(16, k) = afterTax

            Cells(17, k) = afterAddTax

            Cells(18, k) = afterAddTax - transTaxFee

            Cells(12, k) = tradeType

            '운송비

            i = 4

            Do While i < 999

                '몰테일 배송비

                mstartWeight = Cells(i, 10)

                If mstartWeight < weightAll Then

                    i = i + 1

                Else

                    mTransFee = Cells(i, 11).Value

                    i = 999

                End If

            Loop

            lastTransFee = mTransFee

             wonLastTF = lastTransFee * moneyRate

             Cells(19, k) = wonLastTF

            If standardTax < 150000 Or (goodsMoney < 200 And InType = "목록") Then

                 Cells(20, k) = afterAddTax + wonLastTF

            Else

                 Cells(20, k) = afterAddTax + wonLastTF - transTaxFee

            End If

'                 Cells(21, k) = feeSource

            i = 4

            Do While i < 999

                '이하넥스 배송비

                estartWeight = Cells(i, 10)

                If estartWeight < weightAll Then

                    i = i + 1

                Else

                    eLTransFee = Cells(i, 13).Value

                    eNTransFee = Cells(i, 14).Value

                    i = 999

                End If

            Loop

            If eLTransFee > eNTransFee Then

                lastTransFee = eNTransFee

                feeSource = "이하넥스 뉴저지"

            Else

                lastTransFee = eLTransFee

                feeSource = "이하넥스 LA"

            End If

             wonLastTF = lastTransFee * moneyRate

             Cells(21, k) = wonLastTF

            If standardTax < 150000 Or (goodsMoney < 200 And InType = "목록") Then

                 Cells(22, k) = afterAddTax + wonLastTF

            Else

                 Cells(22, k) = afterAddTax + wonLastTF - transTaxFee

            End If

            '예상 세금

            Cells(23, k) = feeSource

            Cells(24, k) = afterAddTax - transTaxFee - sumKoreaWon

        End If

        k = k + 1

    Loop

End Sub

회사와 직급, 이름을 기준으로 한 회사에 두명 이상이 등록되어 있으면 검토하는 매크로입니다.

수작업을 거쳐야 하는데 필터를 이름->직급->회사 순으로 내림차순 정렬하셔야 합니다. 

이렇게 하면 회사 기준 -> 직급 -> 이름으로 정렬됩니다.  

나머지는 실제 실행하면서 확인하시길 바랍니다. 

row-delete.xlsm

'컬럼을 비교해서 삭제하는 부분입니다. 

Sub chkColumnsNext()

    Range(Cells(7, 14), Cells(100, 15)).Delete

    Sheets(1).Select

    Cells(2, 2).Select

    ActiveCell.FormulaR1C1 = "=COUNTA(R[5]C[4]:R[10000]C[4])"

    sameRowCnt = 1

    colCnt = Cells(2, 2)

    i = 7

    Do While i < colCnt + 7

        Cells(2, 4) = i

        Cells(i, 2).Select

        stdColName = Cells(i, 2)

        stdColType = Cells(i, 3)

        stdColLen = Cells(i, 4)

        cmpColName = Cells(i + 1, 2)

        cmpColType = Cells(i + 1, 3)

        cmpColLen = Cells(i + 1, 4)

        '이름이 같으면 타입을 비교함.

        If stdColName = "신원제품" Then

            aaa = bbb

        End If

        If stdColName = cmpColName Then

            sameRowCnt = sameRowCnt + 1

            If stdColType = cmpColType And stdColLen = cmpColLen Then

                Cells(i + 1, 2).Select

                Selection.EntireRow.Delete

            ElseIf stdColType <> cmpColType And stdColLen = cmpColLen Then

                Cells(i + 1, 14).Interior.Color = RGB(255, 100, 100)

                Cells(i + 1, 14) = "직급 상이함"

                i = i + 1

            ElseIf stdColType = cmpColType And stdColLen <> cmpColLen Then

                Cells(i + 1, 15).Interior.Color = RGB(255, 100, 100)

                Cells(i + 1, 15) = "이름 상이함"

                i = i + 1

            ElseIf stdColType <> cmpColType And stdColLen <> cmpColLen Then

                Cells(i + 1, 14).Interior.Color = RGB(255, 100, 100)

                Cells(i + 1, 14) = "직급 상이함"

                Cells(i + 1, 15).Interior.Color = RGB(255, 100, 100)

                Cells(i + 1, 15) = "이름 상이함"

                i = i + 1

            End If

        '이름이 다르면 그냥 넘어감

        Else

            If sameRowCnt = 1 Then

            '    Selection.EntireRow.Delete

                Cells(i, 2).Interior.Color = RGB(100, 255, 100)

                Cells(i, 14) = "적합"

'                Cells(i + 1, 15) = "이름 상이함"

            End If

                i = i + 1

            sameRowCnt = 1

        End If

        colCnt = Cells(2, 2)

    Loop

End Sub

'정렬하는 부분입니다.

Sub setSort()

'

' setSort 매크로

'

    '갯수를 센다

    Range("B5").Select

    ActiveCell.FormulaR1C1 = "=COUNTA(R[2]C:R[94]C)"

    Cells(8, 1) = 1

    Cells(9, 1) = 2

    Range("A8:A9").Select

    Selection.AutoFill Destination:=Range("A8:A81")

    Cells(8, 1).Select

    '정렬 하기

    Range("A6:M6").Select

    afCheck = Selection.AutoFilter

    If afCheck = True Then

    Else

        ActiveSheet.AutoFilter.Sort.SortFields.Add Key:=Range _

            ("B6"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _

            xlSortNormal

        With ActiveWorkbook.Worksheets(1).AutoFilter.Sort

            .Header = xlYes

            .MatchCase = False

            .Orientation = xlTopToBottom

            .SortMethod = xlPinYin

            .Apply

        End With

    End If

End Sub

어떤 특정한 값을 목록과 비교할 때 주로 사용하는것이 vlookup함수입니다. 

그런데 vlookup 함수를 사용할 경우 #N/A 가 자주 나타납니다. 

이것은 찾고자 하는 단어가 목록에 없기 때문에 나타나는 것입니다. 

즉 아래와 같이 함수를 사용했는데 

=VLOOKUP(B4,$F$4:$G$51,2,FALSE)

B4에 해당하는 값이 목록에 없으면 아래의 그림처럼 #N/A가 출력됩니다. 

#N/A는 다루기도 불편하고 보기도 좋지 않지요. 

차라리 ISNA함수를 사용하여 아래와 같이 변경하면 보기 좋은 결과가 나타납니다. 

ISNA()는 ()안의 값이 #N/A 인지 물어보는 것입니다. 

만약 #N/A이면 true를 아니면 false를 리턴합니다. 

따라서 if문을 사용하여 아래와 같이 물어보면 보다 보기 좋은 데이터가 출력됩니다. 

=IF(ISNA(VLOOKUP(B4,$F$4:$G$51,2,FALSE))=TRUE,"해당없음",VLOOKUP(B4,$F$4:$G$51,2,FALSE))

vlookup은 가장 자주 사용하는 함수라서 먼저 등록합니다.