他ブックの目次更新

機能

• 対象ブックの目次を更新する。
  • 「目次」シートが存在しない場合は「目次」シートを追加する。
• 「目次」シートを一番左に移動させる。

シート建付け

• シート名①
  他ブックの目次更新
• シート構成
  • 対象ファイル　→　セルC5
    
• シート名②
  目次tmp
• 備考
  • 対象ブックに目次シートが存在しない場合にコピーするために使用。
  • 常に非表示（処理内で一時的に表示させるが、処理完了後に再度非表示）
    

ソースコード

Module1

• 共通設定

'シート名
Public Const SHEET_NAME_INDEX = "目次"
Public Const SHEET_NAME_INDEX_TMP = "目次tmp" '非表示
Public Const SHEET_NAME_UPDATE_OTHER_BOOK_INDEX = "他ブックの目次更新"
'カラーインデックス
Public Const WEAK_GRAY = 15

• 処理

'***** 他ブックの目次更新 *****
Sub UpdateOtherBookIndex()


    '----------< ThisBook >----------
    '行数
    Const TARGET_PATH_ROW = 5
    '列数
    Const TARGET_PATH_COL = 3
    'シート名
    Const SHEET_NAME_INDEX = "目次"
    '----------< OtherBook >----------
    '行数
    Const INDEX_START_ROW = 2
    '列数
    Const NO_COL = 1
    Const SHEET_NAME_COL = 2
    Const LINK_COL = 3
    Const VISIBLE_STATUS_COL = 4
    '関数
    Const LINK_FORMURA = _
        "=IF(B2<>"""",HYPERLINK(""#'"" & B2 & ""'!A1"", ""→ "" & B2), """")"
    '文言
    Const STATUS_VISIBLE = "表示"
    Const STATUS_INVISIBLE = "非表示"
    
    'No 初期化
    Dim cntNo As Long
    cntNo = 1
    '編集行 初期化
    Dim workRow As Long
    workRow = INDEX_START_ROW

    '--------------------------------------
    
    '文言
    Const END_MESSAGE = "更新終了"
    
    '対象ファイル名
    Dim targetFullPath As String
    Dim targetFileName As String
    Dim otherBookName As String
    
    
    '処理前アクション
    StartAction SHEET_NAME_UPDATE_OTHER_BOOK_INDEX, False
    
    
    '対象ファイルを開く
    targetFullPath = Cells(TARGET_PATH_ROW, TARGET_PATH_COL).Value
    Workbooks.Open targetFullPath
    otherBookName = ActiveWorkbook.Name
    
    
    '「目次」シート 存在チェック
    Dim mokujiExistFlag As Boolean
    mokujiExistFlag = SheetExistCheck(otherBookName, SHEET_NAME_INDEX)
    
    
    '（「目次」が存在しない場合） シート追加
    If mokujiExistFlag = False Then
        '「目次tmp」コピー
        With ThisWorkbook.Sheets(SHEET_NAME_INDEX_TMP)
            .Visible = True
            .Copy before:=Workbooks(otherBookName).Sheets(1)
            .Visible = False
        End With
        'ファイル名変更
        Workbooks(otherBookName).Sheets(SHEET_NAME_INDEX_TMP).Name _
            = SHEET_NAME_INDEX
    End If
    
        
    'シート 表示/非表示チェック
    Dim visibleFlagDic As Object
    Set visibleFlagDic = SetVisibleFlagDic
        

    '全シート再表示
    AllSheetsVisible otherBookName

        
    '「目次」を先頭に移動
    If Sheets(1).Name <> SHEET_NAME_INDEX Then
        Workbooks(otherBookName).Sheets(SHEET_NAME_INDEX).Move _
            before:=Sheets(1)
    End If
    
    
    'シート数 取得
    Dim sheetCount As Long
    sheetCount = GetSheetCount(otherBookName)
    
    
    '----------< 他ブック目次更新 >----------
    Workbooks(otherBookName).Sheets(SHEET_NAME_INDEX).Activate
    
    
    '既存データ 削除
    Dim maxRow As Long
    maxRow = GetMaxRow(SHEET_NAME_INDEX, NO_COL)
    CellClear _
        SHEET_NAME_INDEX, _
        INDEX_START_ROW, _
        maxRow, _
        NO_COL, _
        VISIBLE_STATUS_COL
    
    
    '2行目 初期化
    With Cells(INDEX_START_ROW, NO_COL)
        'No
        .Value = cntNo
        'シート名
        .Offset(0, 1).Value = SHEET_NAME_INDEX
        'リンク
        .Offset(0, 2).Formula = LINK_FORMURA
        '表示状態
        If visibleFlagDic.Item(SHEET_NAME_INDEX) = True Then
            .Offset(0, 3).Value = STATUS_VISIBLE
        Else
            .Offset(0, 3).Value = STATUS_INVISIBLE
        End If
        .Offset(0, 3).HorizontalAlignment = xlCenter
    End With
    
    
    'シート名 記入
    Dim i As Long
    
    For i = 1 To sheetCount
    
        '3行目以降に対する処理
        If workRow > INDEX_START_ROW Then
            'No挿入
            Cells(workRow, NO_COL).Value = cntNo
            'シート名 代入
            Cells(workRow, SHEET_NAME_COL).Value = Sheets(i).Name
            'リンク表示関数 代入
            FormulaCopyDown workRow, LINK_COL
            '表示状態
            With Cells(workRow, VISIBLE_STATUS_COL)
                If visibleFlagDic.Item(Sheets(i).Name) = True Then
                    .Value = STATUS_VISIBLE
                Else
                    .Value = STATUS_INVISIBLE
                    Range(.Offset(0, -3), .Offset(0, 0)).Interior.ColorIndex = WEAK_GRAY
                End If
                .HorizontalAlignment = xlCenter
            End With
        End If

        'No 更新
        cntNo = cntNo + 1
        '次の行へ
        workRow = workRow + 1
    
    Next i
    
    
    'オートフィルタ
    Workbooks(otherBookName).Sheets(SHEET_NAME_INDEX).Cells(INDEX_START_ROW, NO_COL).Select
    Selection.CurrentRegion.AutoFilter
    
    
    '（非表示だったシートのみ）再非表示
    Dim tmpVisFlag As Boolean
    Dim ws As Worksheet
    
    For Each ws In Worksheets
        tmpVisFlag = visibleFlagDic.Item(ws.Name)

        If tmpVisFlag = False Then
            ws.Visible = tmpVisFlag
        End If
    
    Next
    

    '列幅自動調整
    ColAutoFit NO_COL, LINK_COL
    
    
    '表示位置 調整
    With ActiveWindow
        'Ctrl + HOMEの位置にカーソル移動
        ActiveWindow.ActiveSheet.Cells(.SplitRow + 1, .SplitColumn + 1).Activate
        '左上にスクロール
        .ScrollRow = .SplitRow + 1
        .ScrollColumn = .SplitRow + 1
    End With
     
     
    '処理後アクション
    EndAction SHEET_NAME_UPDATE_OTHER_BOOK_INDEX, END_MESSAGE
    
    
End Sub


'***** フォルダ存在確認 *****
Sub FolderExistCheck()

    '行数
    Const START_WORK_ROW = 4
    '列数
    Const NO_COL = 1
    Const PATH_COL = 2
    Const RESULT_COL = 3
    Const PATH_BKUP_COL = 10
    '文言
    Const CHECK_RESULT_OK = "OK"
    Const CHECK_RESULT_NG = "NG"
    Const END_MESSAGE = "チェック完了"

    'No 初期化
    Dim cntNo As Long
    cntNo = 1
    'パス 初期化
    Dim tmpPath As String
    tmpPath = ""


    '処理前アクション
    StartAction SHEET_NAME_FOLDER_EXISTS_CHK
    
    
    '最大行取得
    Dim maxRow As Long
    maxRow = GetMaxRow(SHEET_NAME_FOLDER_EXISTS_CHK, PATH_COL)
    
    
    'パス 一時対比
    Range(Cells(START_WORK_ROW, PATH_COL), Cells(maxRow, PATH_COL)).Copy _
        Cells(START_WORK_ROW, PATH_BKUP_COL)
    

    '既存データ 削除
    ClearContents SHEET_NAME_FOLDER_EXISTS_CHK, START_WORK_ROW, Rows.Count, NO_COL, RESULT_COL


    'パス 復元
    Range(Cells(START_WORK_ROW, PATH_BKUP_COL), Cells(maxRow, PATH_BKUP_COL)).Copy _
        Cells(START_WORK_ROW, PATH_COL)
    Columns(PATH_BKUP_COL).Clear
       
    
    'フォルダ存在確認
    Dim i As Long
    
    For i = START_WORK_ROW To maxRow
    
        'No挿入
        Cells(i, NO_COL).Value = cntNo
        
        '存在チェック
        tmpPath = Cells(i, PATH_COL).Value
        If Dir(tmpPath, vbDirectory) <> "" Then
            Cells(i, RESULT_COL).Value = CHECK_RESULT_OK
        Else
            Cells(i, RESULT_COL).Value = CHECK_RESULT_NG
        End If
        
        'No更新
        cntNo = cntNo + 1
        
    Next i

    '処理後アクション
    EndAction SHEET_NAME_FOLDER_EXISTS_CHK, END_MESSAGE

End Sub
'***** 処理後アクション *****
'機能：① Excelの描画を再開させる。
'　　：② [Ctrl + HOME] を押下した位置にカーソルを移動させる。
'　　：③ 終了メッセージを表示させる。
Sub EndAction(ByVal sheetName As String, ByVal endMessage As String)

    ThisWorkbook.Activate
    
    '描画再開
    Application.ScreenUpdating = True
    
    '対象シート 有効化
    Sheets(sheetName).Activate
    
    'Ctrl + HOMEの位置にカーソル移動
    With ActiveWindow
        ActiveWindow.ActiveSheet.Cells(.SplitRow + 1, .SplitColumn + 1).Activate
    End With
    
    '終了メッセージ 表示
    MsgBox endMessage

End Sub


'***** シート数 取得 *****
'機能：対象ブックのシート数を取得する。
Function GetSheetCount(ByVal targetBookName As String) As Long

    GetSheetCount = Workbooks(targetBookName).Sheets.Count

End Function


'***** 最大行 取得 *****
'機能：最大行を取得する。
Function GetMaxRow(ByVal targetSheetName As String, ByVal targetCol As Long) As Long

    GetMaxRow = Sheets(targetSheetName).Cells(Rows.Count, targetCol).End(xlUp).Row

End Function


'***** 数式コピー（Ctrl + D） *****
'機能：一行上の数式をコピーする。
Sub FormulaCopyDown(ByVal targetRow As Long, ByVal targetCol As Long)

    Cells(targetRow - 1, targetCol).Copy
    Cells(targetRow, targetCol).PasteSpecial Paste:=xlPasteFormulas

End Sub


'***** 列幅 自動調整 *****
'機能：対象列（複数でも可）の幅を自動調整する。
Sub ColAutoFit(ByVal startCol As Long, ByVal endCol As Long)

    Range(Columns(startCol), Columns(endCol)).AutoFit

End Sub


'***** ファイル数 取得 *****
'機能：対象フォルダ内のファイル数を取得する。
Function GetFileCount(ByVal targetFolder As String, ByVal tmpExtension As String) As Long

    Const SEARCH_NAME = "*"
    Dim tmpFilename As String
    tmpFilename = SEARCH_NAME & tmpExtension
    
    Dim fileCount As Long
    fileCount = 0
    
    Dim filePath As String
    filePath = Dir(targetFolder & DELIMITER_BS & tmpFilename)
    
    Do While filePath <> ""
        fileCount = fileCount + 1
        filePath = Dir()
    Loop
    
    GetFileCount = fileCount

End Function


'***** シート存在チェック *****
'機能：特定の名前のシートが存在するかチェックする。
Function SheetExistCheck(ByVal targetBookName As String, ByVal targetSheetName As String) As Boolean
    
    Dim ws As Worksheet
    Dim checkResult As Boolean

    Workbooks(targetBookName).Activate
        
    '存在チェック
    For Each ws In Worksheets
        If ws.Name = targetSheetName Then
            checkResult = True
            Exit For
        Else
            checkResult = False
        End If
    Next
    
    SheetExistCheck = checkResult
    
End Function


'***** シート表示状態 取得 *****
'機能：全シートの表示 / 非表示を連想配列に記録して返す。
Function SetVisibleFlagDic() As Object
    
    Dim tmpDic As Object
    Set tmpDic = CreateObject("Scripting.Dictionary")
    Dim ws As Worksheet
    
    For Each ws In Worksheets
        tmpDic.Add ws.Name, ws.Visible
    Next
    
    Set SetVisibleFlagDic = tmpDic

End Function


'***** 全シート表示 *****
'機能：全シートの表示させる。
Sub AllSheetsVisible(Optional ByVal bookName As String = "")
    
    Dim ws As Worksheet
    
    If bookName <> "" Then
        Workbooks(bookName).Activate
    Else
        ThisWorkbook.Activate
    End If
    
    For Each ws In Worksheets
        ws.Visible = True
    Next
    
End Sub


'***** 対象範囲 クリア *****
'機能：対象範囲のデータや書式を削除
Sub CellClear(ByVal sheetName As String, ByVal startRow As Long, ByVal endRow As Long, ByVal startCol As Long, ByVal endCol As Long)

    Sheets(sheetName).Range( _
        Cells(startRow, startCol), Cells(endRow, endCol) _
    ).Clear

End Sub

ソースコードの全量は こちら
※転記漏れがあるかもしれないので。