목차 만들기 자동화 함수 :: 엑셀 CreateTOC 사용법 및 전체 코드

'###############################################################
'오빠두엑셀 VBA 사용자 지정함수 (https://www.oppadu.com)
'■ CreateTOC 명령문
'■ 통합문서의 각 시트를 기준에따라 정렬 및 분류하여 목차를 생성합니다.
'■ 인수 설명
'_____________SortByLength      : 시트를 분류할 기준입니다. 숫자 또는 기호를 받아옵니다.
'_____________SortOrder         : 시트 정렬 방향입니다. (1: 오름차순, -1: 내림차순, 0: 정렬안함)
'_____________resultBtn         : 목차로 돌아가기 링크 생성 여부입니다.
'_____________BtnCell           : 목차로 돌아가기 링크를 생성할 셀 주소입니다.
'■ 사용된 기타 사용자지정함수
'_____________SortArray 함수
'■ 그외 참고사항
'###############################################################
 
Sub CreateTOC(Optional SortByLength As Variant = "", Optional SortOrder As Long = 0, Optional returnBtn As Boolean = False, Optional BtnCell As String = "A1")
 
Dim WB As Workbook: Dim WS As Worksheet: Dim tocWS As Worksheet
Dim vaArr As Variant
Dim i As Long: Dim x As Long: Dim j As Long: Dim jj As Long: x = 0: j = 0: jj = 1
Dim groupLen As Variant: Dim prefix As String: groupLen = 0
 
Application.ScreenUpdating = False
 
Set WB = ActiveWorkbook
Set tocWS = WB.Worksheets.Add(Before:=WB.Worksheets(1))
 
'<--! 임시 배열 생성 -->;
ReDim vaArr(0 To WB.Worksheets.Count - 2)
For i = 2 To WB.Worksheets.Count
    Set WS = WB.Worksheets(i)
    '// ======= 2020.01.09 숨김시트 목록에서 제외 ========
    If WS.Visible = xlSheetVisible Then vaArr(j) = WB.Worksheets(i).Name: j = j + 1
Next
 
'// ======= 2020.01.09 배열 Redim 및 변수 초기화 ========
ReDim Preserve vaArr(0 To j - 1)
j = 0
 
'<--! 임시 배열 정렬 -->;
If SortOrder = 1 Then vaArr = SortArray(vaArr, xlAscending)
If SortOrder = -1 Then vaArr = SortArray(vaArr, xlDescending)
 
tocWS.Activate
ActiveWindow.DisplayGridlines = False
 
'<--! 목차시트 꾸미기 -->;
With tocWS
    On Error GoTo shtexist
    .Name = "목차"
resume_1:
    .Tab.Color = RGB(47, 47, 47)
    .Range("A:B").EntireColumn.ColumnWidth = 4
    .Range("4:500").EntireRow.RowHeight = 20
    .Range("2:2").Interior.Color = RGB(47, 47, 47)
    .Range("1:1").EntireRow.RowHeight = 11
 
    With .Range("B2")
        .Value = "목차"
        .Font.Bold = True
        .Font.Size = 18
        .Font.Color = RGB(255, 255, 255)
    End With
 
    .Range("B4").Value = "#"
    .Range("C4").Value = "시트명"
    With .Range("B4").EntireRow
        .Font.Bold = True
        .Font.Color = RGB(255, 255, 255)
        .Interior.Color = RGB(89, 89, 89)
    End With
 
'<--! 임시 배열의 값을 하나씩 돌아가며 목차 생성 -->;
    For i = LBound(vaArr) To UBound(vaArr)
 
        If IsNumeric(SortByLength) = True Then
            groupLen = SortByLength
        Else
            If InStr(1, vaArr(i), SortByLength) > 0 Then groupLen = InStr(1, vaArr(i), SortByLength) - 1
        End If
        On Error Resume Next
        If Left(vaArr(i - 1), groupLen) <> Left(vaArr(i), groupLen) Then
 
            If (i = LBound(vaArr) And SortOrder = 0) Then
                j = j + 1: jj = 1
            Else
                j = j + 1: jj = 1
                .Cells(x + 5, 2).Value = j
                .Cells(x + 5, 3).Value = Left(vaArr(i), groupLen)
                If .Cells(x + 5, 3).Value = "" Then .Cells(x + 5, 3).Value = "기타항목"
                .Cells(x + 5, 2).NumberFormat = "0*."
                .Cells(x + 5, 1).EntireRow.Font.Bold = True
                .Cells(x + 5, 1).EntireRow.Interior.Color = RGB(245, 245, 245)
                x = x + 1
            End If
            On Error GoTo 0
        Else
            jj = jj + 1
        End If
 
        If blnSort = True Then prefix = "'" & j & "-"
 
        .Cells(x + 5, 2).Value = prefix & jj
        .Cells(x + 5, 2).NumberFormat = "_~@"
        .Hyperlinks.Add anchor:=.Cells(x + 5, 3), Address:="", SubAddress:="'" & CStr(vaArr(i)) & "'!A1", TextToDisplay:="'" & vaArr(i) '// 2020.02.11 수정 : 숫자형식 시트명 텍스트형식으로 변경
        .Cells(x + 5, 3).InsertIndent 1
 
        x = x + 1
    Next
 
    .Range("C:C").EntireColumn.AutoFit
 
End With
 
'<--! 각 시트에 '목차로 돌아가기' 링크 생성 -->;
If returnBtn = True Then
    For i = 2 To WB.Worksheets.Count
        WB.Worksheets(i).Hyperlinks.Add anchor:=WB.Worksheets(i).Range(BtnCell), Address:="", SubAddress:=tocWS.Name & "!A1", TextToDisplay:="목차로 돌아가기"
        WB.Worksheets(i).Range(BtnCell).Font.Bold = True
    Next
End If
 
 
Application.ScreenUpdating = True
 
Exit Sub
 
shtexist:
    tocWS.Name = "목차" & Format(Now, "yyyymmddhhmmss")
    On Error GoTo 0
    Resume resume_1
 
End Sub