무성의한 블로그

엑셀 매크로에서 폴더 창을 띄울 때 원하는 창으로 들어가는 방법

폴더의 initialFileName을 정해주면 된다.

아래와 같음

Dim fd As FileDialog

Set fd = application.filedialog(msofiledialogfilepicker)

set fs = createobject("scripting.FileSystemObject")

Cells(3,1) = ""

with fd

.InitialFileName = "D:\temp\"

.AllowMultiSselect = true

If .show = 0 then

cells(3,1) = "작업을 취소하셨습니다."

cells(3,1).font.color = RGB(240,0,0)

cells(3,1).font.bold = true

else

.....

end if

end with

set fd = nothing

행 하나를 삭제할 때

rows(51).select

selection.delete shift :=xlUP

countA를 사용할 때

cells(3,4) = "count(d4:d5000)"

'내부의 위치에는 따옴표를 사용하지 않는다.

차트 그릴 때

'크기 위치 고정

Activesheet.shapes(1).Placement = xlFreeFloating

'차트 제목입력

Activesheet.ChartObjects(1).Activate

ActiveChart.ChartTitle.Select

ActiveChart.ChartTitle.Text = "월별실적"

'차트가 있는지 확인하고 삭제

chtCnt= Activesheet.ChartObjects.Count

if chtCnt > 0 then

Activesheet.ChartObjects(1).Delete

end if

'퍼센트 유형 변경

Range("t5:t50").select

selection.Style = "Percent"

'이미지파일 수 세기

shpCnt = ActiveSheet.Shapes.Count

imgNum = 0

i = 1

Do while i < shpCnt + 1

if activeSheet.shapes.item(shpECnt).type = 13 then 'type = 13이 그림파일임

imgNum = imgNum + 1

end if

i = i + 1

loop

cells(3,4) = imgNum   'imgNum is number of image

rows(14).Insert

Columns(14).Insert

인력투입관리.xlsm

약간 개선하였습니다. 

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

프로젝트를 관리하다보면 투입인력 현황을 체크해야 하는 상황이 발생합니다. 

이걸 매일 관리하기도 힘들고 그렇다고 한달에 한번만하기도 그렇고...

그래서 만들었습니다. 인력관리매크로

첫페이지에 투입인력 정보를 입력합니다. 

두번째 페이지에 해당 인력의 투입내역이 나타나는 구조입니다. 

먼저 인력 정보를 입력하는 화면입니다 

이름 소속사 업무 투입일과 철수일 등급을 입력합니다.

그리고 전체처리 버튼을 클릭합니다. 

그러면 다음페이지에 아래와 같은 모양이 나타납니다. 

먼저 회사 업무 등 의 타이틀과 날짜는 입력해 두어야 합니다. 

7번째 행은 현재까지 인력별 투입일수입니다. 

세번째 열은 현재 투입되어 있는 인력의 수 입니다. 

철수일은 오늘을 기준으로 철수한 인력에만 표시됩니다. 

오늘 날짜에 노란색 채우기가 된 부분은 자동서식을 적용했습니다. 

셀값 = today()를 사용하였습니다. 

일일 현황을 보려면 '일일현황'버튼을 만드록 dayStat()을 지정하면됩니다. 

여기서부터 매크로 소스입니다. 

간단한 소스입니다. 그래도 편리하게 사용하실 수 있습니다. 

Sub setHPlanAll()

       '두번째시트에 명칭을 부여했음

    Sheets("일자별현황").Select

    Range(Cells(1, 4), Cells(6, 120)).ClearContents

    Range(Cells(8, 4), Cells(365, 120)).ClearContents

    '작업기준일

    If Cells(2, 1) = "" Then

        Cells(2, 1) = Date

    End If

    chkDate = Cells(2, 1)

    Sheets("투입인력목록").Select

    '4번째부터 값을 부여함.

    i = 4

    Do While i < 100 '100명이 넘지 않는 인력이 투입됨

        '해지 = 해지가 나오면 이하 모두 해지

        hejiMan = Cells(i, 1)

        If hejiMan = "해지" Then

            Exit Do

        End If

        '이름'

        Sheets("일자별현황").Cells(3, i) = Cells(i, 2)

        '회사'

        Sheets("일자별현황").Cells(1, i) = Cells(i, 3)

        '업무'

        Sheets("일자별현황").Cells(2, i) = Cells(i, 4)

        '투입일

        Sheets("일자별현황").Cells(5, i) = Cells(i, 5)

        '등급'

        Sheets("일자별현황").Cells(4, i) = Cells(i, 9)

        '철수일

        outDate = Cells(i, 6)

        If outDate <= Date Then

            Sheets(2).Cells(6, i) = Cells(i, 6)

        Else

        End If

        '다 했으면 종료

        If Cells(i, 2) = "" Then

            Exit Do

        End If

        '투입일'

        inDate = Cells(i, 5)

        '철수일'

        '2번 시트로 이동함

        Sheets("일자별현황").Select

        dd = 8

        Do While dd < 300

            sdDate = Cells(dd, 1)

            If inDate <= sdDate Then

                Cells(dd, i) = 1

            End If

            If inDate = outDate Then

                Exit Do

            End If

            If sdDate > outDate Then

                Exit Do

            End If

            If sdDate = chkDate Then

                Exit Do

            End If

            dd = dd + 1

        Loop

        '1번 시트로 이동함

        Sheets("투입인력목록").Select

        i = i + 1

    Loop

    '2번 시트로 이동함

    Sheets("일자별현황").Select

End Sub

프로젝트를 관리하다보면 투입인력 현황을 체크해야 하는 상황이 발생합니다. 

이걸 매일 관리하기도 힘들고 그렇다고 한달에 한번만하기도 그렇고...

그래서 만들었습니다. 인력관리매크로

첫페이지에 투입인력 정보를 입력합니다. 

두번째 페이지에 해당 인력의 투입내역이 나타나는 구조입니다. 

먼저 인력 정보를 입력하는 화면입니다 

이름 소속사 업무 투입일과 철수일 등급을 입력합니다.

그리고 전체처리 버튼을 클릭합니다. 

그러면 다음페이지에 아래와 같은 모양이 나타납니다. 

먼저 회사 업무 등 의 타이틀과 날짜는 입력해 두어야 합니다. 

7번째 행은 현재까지 인력별 투입일수입니다. 

세번째 열은 현재 투입되어 있는 인력의 수 입니다. 

철수일은 오늘을 기준으로 철수한 인력에만 표시됩니다. 

오늘 날짜에 노란색 채우기가 된 부분은 자동서식을 적용했습니다. 

셀값 = today()를 사용하였습니다. 

여기서부터 매크로 소스입니다. 

간단한 소스입니다. 그래도 편리하게 사용하실 수 있습니다. 

Sub setHPlanAll()

    Sheets(2).Select

    Range(Cells(1, 4), Cells(6, 120)).ClearContents

    Range(Cells(8, 4), Cells(300, 120)).ClearContents

    Sheets(1).Select

    i = 4

    Do While i < 100

        '회사'

        Sheets(2).Cells(1, i) = Cells(i, 3)

        '업무'

        Sheets(2).Cells(2, i) = Cells(i, 4)

        '이름'

        Sheets(2).Cells(3, i) = Cells(i, 2)

        '등급'

        Sheets(2).Cells(4, i) = Cells(i, 9)

        '투입일

        Sheets(2).Cells(5, i) = Cells(i, 5)

        '철수일

        outDate = Cells(i, 6)

        If outDate <= Date Then

                    Sheets(2).Cells(6, i) = Cells(i, 6)

        Else

        End If

        '다 했으면 종료

        If Cells(i, 2) = "" Then

            Exit Do

        End If

        '투입일'

        inDate = Cells(i, 5)

        '철수일'

        '2번 시트로 이동함

        Sheets(2).Select

        dd = 8

        Do While dd < 300

            sdDate = Cells(dd, 1)

            If inDate <= sdDate Then

                Cells(dd, i) = 1

            End If

            If sdDate = outDate Then

                Exit Do

            End If

            If sdDate = Date Then

                Exit Do

            End If

            dd = dd + 1

        Loop

        '1번 시트로 이동함

        Sheets(1).Select

        i = i + 1

    Loop

    '2번 시트로 이동함

    Sheets(2).Select

End Sub

난수를 쉽게 공부하자.

Sub 단추1_Click()

    makeNum = Cells(1, 2)

    If makeNum < 1 Then

        makeNum = 100

    End If

    i = 3

    Do While i < makeNum + 3

        Cells(i, 1) = i - 2

        j = 2

        Do While j < 8

            Cells(i, j) = Int((46 * Rnd) + 1)

            j = j + 1

        Loop

        '정렬하기

        Call sortNums(i, n)

        '중복찾기

        Call getSame(i, n)

        Cells(i, 8) = Cells(i, 2) & Cells(i, 3) & Cells(i, 4) & Cells(i, 5) & Cells(i, 6) & Cells(i, 7)

        i = i + 1

    Loop

End Sub

Function sortNums(i, n)

    Range(Cells(i, 2), Cells(i, 7)).Select

    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Clear

    ActiveWorkbook.Worksheets("Sheet2").Sort.SortFields.Add Key:=Range(Cells(i, 2), Cells(i, 7)), _

        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal

    With ActiveWorkbook.Worksheets("Sheet2").Sort

        .SetRange Range(Cells(i, 2), Cells(i, 7))

        .Header = xlGuess

        .MatchCase = False

        .Orientation = xlLeftToRight

        .SortMethod = xlPinYin

        .Apply

    End With

End Function

Function getSame(i, n)

    k = 2

    Do While k < 8

        If Cells(i, k) = Cells(i, k + 1) Then

            Cells(i, k) = Int((46 * Rnd) + 1)

            Call sortNums(i, n)

            Call getSame(i, n)

        End If

        k = k + 1

    Loop

End Function

프로그램 목록을 비교하는 매크로입니다. 

제대로 된 설명이 없어서 소스코드를 보면서 이해하긴 힘듭니다. 

초기 소스라 정제되어 있지 않습니다. 

그렇지만 정제되어 있지 않기에 매크로 공부하기에는 좋지 않을까요? 

엑셀의 도움말을 활용하였으며 일부 소스는 인터넷에 공개된 내용을 참조했습니다. 

Sub save_Sheet()

    Dim i As Integer

    Dim j As Integer

    Dim targetCount  As Integer

    Dim rowCount As Integer

    Dim chkValue As String

    Dim targetValue As String

    '데이터 정리

    Range(Cells(12, 16), Cells(1000, 18)).Select

    Selection.ClearContents

    '처리전에 정렬하고 작업 들어감

    sortTables

    rowCount = Cells(10, 7)

    targetCount = Cells(10, 29)

    testCount = Cells(10, 53)

    i = 12

    j = 12

    '먼저 i를 하나씩 돌면서 처리함.

    '개발여부 체크

    Cells(2, 9) = Time

    Do While i < rowCount + 12

        chkValue = Cells(i, 7)

        Cells(2, 10) = i

        Do While j < targetCount + 12

            Cells(2, 11) = j

            targetValue = Cells(j, 28)

            '파일ID이 같으면

            If targetValue = chkValue Then

                '화면

                SetValue = Cells(j, 43)

                Cells(i, 16) = SetValue

                '구현여부

                SetValue = Cells(i, 44)

                If SetValue = "개발없음" Then

                    Cells(i, 4) = SetValue

                End If

                '구현

                SetValue = Cells(j, 45)

                Cells(i, 17).Select

                Cells(i, 17) = SetValue

                '파일비교 대상을 벗어나면

            ElseIf targetValue > chkValue Then

                Exit Do

            End If

            j = j + 1

        Loop

        i = i + 1

    Loop

''''''''''''''''''''''''''''''''''''

    i = 12

    j = 12

    Cells(4, 9) = Time

    '먼저 i를 하나씩 돌면서 처리함.

    Do While i < rowCount + 12

        chkValue = Cells(i, 7)

        Cells(4, 7) = i

        Cells(5, 7) = j

       ' Cells(2, 18) = i

        Do While j < testCount + 12

            targetValue = Cells(j, 53)

            testResult = Cells(j, 59)

            If targetValue = chkValue Then

                If testResult = "PASS" Then

                    SetValue = Cells(j, 60)

                    Cells(i, 18) = SetValue

                Else

                    Cells(i, 18) = "FAIL"

                End If

            ElseIf targetValue > chkValue Then

                Exit Do

            End If

            j = j + 1

        Loop

        '비교 끝나면 종료

        If j >= testCount + 12 Then

            Exit Do

        End If

        i = i + 1

    Loop

    Range("r12:r1000").Select

    Selection.Replace What:=".", Replacement:="-", LookAt:=xlPart, _

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

    ReplaceFormat:=False

    Range("a1:zz1000").Select

    With Selection.Font

        .Name = "맑은 고딕"

        .Size = 10

    End With

    drawLine

    saveHistory

End Sub

Sub sortTables()

'

' Macro1 Macro

'

'비교 데이터

    Range("a12:w1000").Select

    ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear

    ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range( _

        "G12:G1000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _

        xlSortNormal

    With ActiveWorkbook.Worksheets(1).Sort

        .SetRange Range("A12:w1000")

        .Header = xlGuess

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With

'사업자 제공 진척현황

    Range("z12:Aw1000").Select

    ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear

    ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range( _

        "ab12:ab1000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _

        xlSortNormal

    With ActiveWorkbook.Worksheets(1).Sort

        .SetRange Range("z12:Aw1000")

        .Header = xlGuess

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With

'단위테스트 결과

    Range("ay12:bi1000").Select

    ActiveWorkbook.Worksheets(1).Sort.SortFields.Clear

    ActiveWorkbook.Worksheets(1).Sort.SortFields.Add Key:=Range( _

        "ba12:ba1000"), SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:= _

        xlSortNormal

    With ActiveWorkbook.Worksheets(1).Sort

        .SetRange Range("ay12:bi1000")

        .Header = xlGuess

        .MatchCase = False

        .Orientation = xlTopToBottom

        .SortMethod = xlPinYin

        .Apply

    End With

    Cells(3, 16).Select

End Sub

Sub saveHistory()

'

' Macro1 Macro

'

    ' 시트를 새로 만든다.

    orgBookName = ActiveWorkbook.Name

    '먼저 기존 파일 존재 여부 체크함.

    dFile = "C:\Users\Standard\Desktop\감리 통합폴더\MACRO\추이분석\"

    fFile = "추이분석-" & Year(Date) & Month(Date) & ".xlsx"

    newFileName = dFile & fFile

    Set fs = CreateObject("Scripting.FileSystemObject")

    fileChkTF = fs.fileexists(newFileName)

    '만약 파일이 있으면 기존 파일에 시트를 추가하고 시트명을 부여함.

    If fileChkTF = True Then

        Workbooks.Open newFileName

        Sheets.Add before:=Sheets(1)

        Sheets(1).Name = "추이분석-" & Date & Hour(Time) & Minute(Time) & Second(Time)

    ' 만약 파일이 ㅓㅄ으면 새로 파일을 만들어 시트명을 변경함.

    Else

        Workbooks.Add

        ActiveWorkbook.SaveAs Filename:=newFileName, FileFormat:=xlOpenXMLWorkbook, CreateBackup:=False

        Sheets(1).Name = "추이분석-" & Date & Hour(Time) & Minute(Time) & Second(Time)

    End If

    '복사하기

    Workbooks(orgBookName).Activate

    Sheets(1).Select

    Range("A1:zz1000").Select

    Selection.Copy

    Workbooks(fFile).Activate

    Sheets(1).Select

    Range("A1").Select

    Sheets(1).Paste

    Workbooks(orgBookName).Activate

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

    Cells(1, 1) = Now()

    Application.CutCopyMode = False

    ActiveWorkbook.Save

End Sub

Sub Macro2()

'

' Macro2 Macro

'

'

    Range("L9:P23").Select

    With Selection.Font

        .Name = "굴림"

        .Size = 9

        .Strikethrough = False

        .Superscript = False

        .Subscript = False

        .OutlineFont = False

        .Shadow = False

        .Underline = xlUnderlineStyleNone

        .TintAndShade = 0

        .ThemeFont = xlThemeFontNone

    End With

End Sub

Sub drawLine()

'

' Macro3 Macro

    pgmCnt = Cells(10, 7).Value

    Range(Cells(12, 1), Cells(pgmCnt + 12, 23)).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

    '굵은선 긋기

    Range(Cells(12, 16), Cells(pgmCnt + 12, 19)).Select

    With Selection.Borders(xlEdgeLeft)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlMedium

    End With

    With Selection.Borders(xlEdgeTop)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlMedium

    End With

    With Selection.Borders(xlEdgeBottom)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlMedium

    End With

    With Selection.Borders(xlEdgeRight)

        .LineStyle = xlContinuous

        .ColorIndex = 0

        .TintAndShade = 0

        .Weight = xlMedium

    End With

End Sub

Sub getFileInfo()

    '파일명만 가져옴.

    Dim fd As FileDialog

    Set fd = Application.FileDialog(msoFileDialogFilePicker)

    Dim vrtSelectedItem As Variant

    '기존 정보 제거

    Range(Cells(5, 11), Cells(5, 13)).Select

    Selection.Clear

    idxItems = 1

    With fd

        .InitialFileName = "C:\Users\Standard\Desktop\감리 통합폴더\MACRO\"

        .AllowMultiSelect = True

'        .AllowMultiSelect = False

        If .Show = -1 Then

            '파일폴더만 가져옴

            myFolderName = .InitialFileName

            nameLenth = Len(myFolderName)

            Cells(5, idxItems + 11).Value = myFolderName

            For Each vrtSelectedItem In .SelectedItems

                '폴더+파일명 가져옴

                fileFullName = vrtSelectedItem

                '파일명을 자름

                myFileName = Mid(fileFullName, nameLenth + 1)

                Cells(5, idxItems + 12) = myFileName

                idxItems = idxItems + 1

            Next vrtSelectedItem

        'The user pressed Cancel.

        Else

        End If

    End With

    'Set the object variable to Nothing.

    Set fd = Nothing

    fstFile = Cells(5, 13)

    scdFile = Cells(5, 14)

    If Mid(fstFile, 1, 4) = "PMO_" Then

        Cells(5, 13) = scdFile

        Cells(5, 14) = fstFile

    End If

End Sub

Sub getRawData()

    ' 파일중 작업할 내용을 복사해 옴

    ' 시작한 화면.

    orgBookName = ActiveWorkbook.Name

    '데이터 정리

    Range(Cells(11, 26), Cells(1000, 65)).Select

    Selection.Clear

    ' 파일열기

    d_name = Sheets(1).Cells(5, 12).Value

    '첫번째

    f_name1 = Sheets(1).Cells(5, 13).Value

    '두번째

    f_name2 = Sheets(1).Cells(5, 14).Value

    If Mid(f_name1, 1, 3) = "PMO" Then

        f_name3 = f_name1

        f_name1 = f_name2

        f_name2 = f_name3

    End If

    file_name1 = d_name & f_name1

    file_name2 = d_name & f_name2

    Dim fs, f, s

    Set fs = CreateObject("Scripting.FileSystemObject")

    ' 첫번재 파일 처리

    ' 프로그램 목록 가져오기

    Set f = fs.GetFile(file_name1)

    Workbooks.Open Filename:=file_name1

    Workbooks(f_name1).Activate

    Selection.AutoFilter

    Sheets(2).Select

    Range(Cells(4, 3), Cells(1000, 26)).Select

    Selection.Copy

    Workbooks(orgBookName).Activate

    Cells(11, 26).Select

    ActiveSheet.Paste

    '파일 닫기

    Application.DisplayAlerts = False

    Workbooks(f_name1).Close SaveChanges:=False

    ' 두번째 파일 처리

    ' 단위테스트 결과 가져오기

    Set f = fs.GetFile(file_name2)

    Workbooks.Open Filename:=file_name2

    Selection.AutoFilter

    ' 두번째 파일

    ' 첫번째 시트 처리

    shtPnt = 5

    shtCnt = ActiveWorkbook.Sheets.Count

    Do While shtPnt < shtCnt + 1

        '테스트 결과 복사해오기

        Workbooks(f_name2).Activate

        Sheets(shtPnt).Select

        If shtPnt = 5 Then

            Range(Cells(2, 1), Cells(1000, 11)).Select

        Else

            Range(Cells(3, 1), Cells(1000, 11)).Select

        End If

        Selection.Copy

        '추이분석 시트에 옮겨적기

        Workbooks(orgBookName).Activate

        Sheets(1).Select

        startPoint = Cells(10, 53)

        If shtPnt = 5 Then

            Cells(11, 51).Select

        Else

            Cells(startPoint + 12, 51).Select

        End If

        ActiveSheet.Paste

        shtPnt = shtPnt + 1

    Loop

    '파일 닫기

    Application.DisplayAlerts = False

    Workbooks(f_name2).Close SaveChanges:=False

End Sub

Sub addListCount()

'오른쪽 리스트를 최신이라 생각하고 왼쪽에 업데이트 한다.

' 1. 왼쪽에 있으나 오른쪽에 없는 것은 삭제된 리스트다.

    '비교를 위해 정렬

    sortTables

    rowCount = Cells(10, 7)

    targetCount = Cells(10, 29)

    pasteCount = Cells(10, 77)

    i = 12

    j = 12

    addedList = 0

    removedList = 0

    '먼저 i를 하나씩 돌면서 처리함.

    '개발여부 체크

    Do While i < rowCount + 12

        chkValue = Cells(i, 7)

        Do While j < targetCount + 12

            targetValue = Cells(j, 28)

            '파일ID이 같으면

            If targetValue = chkValue Then

                '다음 값으로 넘어간다

                existFlag = "Y"

                j = j + 1

                i = i + 1

                Exit Do

            '같은 값을 찾지 못하면

            ' 2. 추가된 리스트는 확인한다.

            ElseIf targetValue < chkValue Then

                existFlag = "F"

                j = j + 1

                addedList = addedList + 1

                Exit Do

            ' 2. 삭제된 리스트는 삭제 항목으로 이동한다.

            ElseIf targetValue > chkValue Then

                existFlag = "F"

                i = i + 1

                removedList = removedList + 1

                Exit Do

             End If

        Loop

    Loop

' 3. 왼쪽 리스트를 복사하여 새 리스트로 업데이트 한다.

    Cells(3, 8) = addedList

    Cells(4, 8) = removedList

    listChangeYN = 0

    If addedList > 0 Then

        listChangeYN = MsgBox("불일치한 파일이 있습니다. 리스트를 변경할까요?", vbOKCancel, "확인")

    ElseIf removedList > 0 Then

        listChangeYN = MsgBox("불일치한 파일이 있습니다. 리스트를 변경할까요?", vbOKCancel, "확인")

    Else

        listChangeYN = MsgBox("불일치한 파일이 없습니다. ", vbOKOnly, "확인")

        listChangeYN = 0

    End If

    If listChangeYN = 1 Then

        newListSet

    End If

    Cells(1, 1).Activate

End Sub

Sub newListSet()

'오른쪽 리스트를 최신이라 생각하고 왼쪽에 업데이트 한다.

' 1. 왼쪽에 있으나 오른쪽에 없는 것은 삭제된 리스트다.

    '비교를 위해 정렬

    sortTables

    rowCount = Cells(10, 7)

    targetCount = Cells(10, 29)

    pasteCount = Cells(10, 77)

    i = 12

    j = 12

    addedList = 0

    '먼저 i를 하나씩 돌면서 처리함.

    Do While i < rowCount + 12

    chkValue = Cells(i, 7)

        Do While j < targetCount + 12

            targetValue = Cells(j, 28)

            '파일ID이 같으면

            If targetValue = chkValue Then

                '다음 값으로 넘어간다

                existFlag = "Y"

                j = j + 1

                i = i + 1

                Exit Do

            '같은 값을 찾지 못하면

            ' 2. 추가된 리스트는 확인한다.

            ElseIf targetValue < chkValue Then

                existFlag = "F"

                j = j + 1

                addedList = addedList + 1

                Exit Do

            ' 2. 삭제된 리스트는 삭제 항목으로 이동한다.

            ElseIf targetValue > chkValue Then

                pasteCount = Cells(10, 77)

                existFlag = "F"

                i = i + 1

                removedList = removedList + 1

                Range(Cells(i, 1), Cells(i, 23)).Copy

                Cells(pasteCount + 12, 71).Select

                ActiveSheet.Paste

                Exit Do

             End If

        Loop

        If i >= rowCount + 12 Then

            Exit Do

        End If

    Loop

' 3. 왼쪽 리스트를 복사하여 새 리스트로 업데이트 한다.

    Range(Cells(12, 5), Cells(1000, 11)).ClearContents

    Range(Cells(12, 26), Cells(1000, 32)).Select

    Selection.Copy

    Cells(12, 5).Select

    ActiveSheet.Paste

End Sub

Sub backup()

''''''''''''''''''''''''''''''''''''''''''''''''''''''

    i = 12

    j = 12

    '먼저 i를 하나씩 돌면서 처리함.

    '개발여부 체크

    Cells(3, 9) = Time

    Do While i < rowCount + 12

        chkValue = Cells(i, 7)

        Cells(3, 10) = i

        Cells(3, 11) = j

        Do While j < targetCount + 12

            targetValue = Cells(j, 28)

            '파일ID이 같으면

            If targetValue = chkValue Then

 '               SetValue = Cells(j, 43)

 '               Cells(i, 16) = SetValue

                SetValue = Cells(i, 44)

                If SetValue = "개발없음" Then

                    Cells(i, 4) = SetValue

                End If

 '               SetValue = Cells(j, 45)

 '               Cells(i, 17) = SetValue

            '파일비교 대상을 벗어나면

            ElseIf targetValue > chkValue Then

                Exit Do

            End If

            j = j + 1

        Loop

        i = i + 1

    Loop

''''''''''''''''''''''''''''''''''''

''''''''''''''''''''''''''''''''''''''''''''''''''''''

    i = 12

    j = 12

    '먼저 i를 하나씩 돌면서 처리함.

    '개발여부 체크

    Cells(4, 9) = Time

    Do While i < rowCount + 12

        chkValue = Cells(i, 7)

        Cells(4, 10) = i

        Cells(4, 11) = j

        Do While j < targetCount + 12

            targetValue = Cells(j, 28)

            '파일ID이 같으면

            If targetValue = chkValue Then

 '               SetValue = Cells(j, 43)

 '               Cells(i, 16) = SetValue

'                SetValue = Cells(i, 44)

'                If SetValue = "개발없음" Then

'                    Cells(i, 4) = SetValue

'                End If

                SetValue = Cells(j, 45)

                Cells(i, 17) = SetValue

            '파일비교 대상을 벗어나면

            ElseIf targetValue > chkValue Then

                Exit Do

            End If

            j = j + 1

        Loop

        i = i + 1

    Loop

''''''''''''''''''''''''''''''''''''

End Sub

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

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