ソースコード全量_20220508

概要

現時点でのソースコード全量（開発途中の処理も含む）
まとめてコピーする用。
機能ごとの概要、シートの建付けは各記事参照。
・目次更新
・他ブックの目次更新
・フォルダ存在チェック
・資材リスト 取得
・シート切り出し

ソースコード

Module1

Option Explicit

'＜ 命名規則 ＞
'定数：CONST_NAME
'変数：varName
'プロシージャ: ProcedureName

'＜ 共通設定 ＞
'シート名
Public Const SHEET_NAME_INDEX = "目次"
Public Const SHEET_NAME_INDEX_TMP = "目次tmp" '非表示
Public Const SHEET_NAME_UPDATE_OTHER_BOOK_INDEX = "他ブックの目次更新"
Public Const SHEET_NAME_FOLDER_EXISTS_CHK = "フォルダ存在確認"
Public Const SHEET_NAME_FOLDER_AND_FILE_LIST = "資材リスト 取得"
Public Const SHEET_NAME_EXPORT_SHEET = "シート切り出し"
Public Const SHEET_NAME_CSV_IMPORT = "CSV取込"
'シート命名ルール
Public Const SHEET_NAME_NG_LIST = "',’,＇,*,:,?,\,￥,＊,／,：,？,[,［,］,],＼,/,<,>"
Public Const MAX_SHEET_NAME_NUM = 31
'拡張子
Public Const EXCEL_EXTENSION = ".xlsx"
Public Const CSV_EXTENSION = ".csv"
'オブジェクト
Public Const FILE_SYSTEM_OBJECT = "Scripting.FileSystemObject"
Public Const DICTIONARY = "Scripting.Dictionary"
'区切り文字
Public Const DELIMITER_BS = "\"
Public Const DELIMITER_C = ","
'カラーインデックス
Public Const WEAK_GRAY = 15


'***** 目次更新 *****
Sub UpdateIndex()
    
    '行数
    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 = "非表示"
    '終了メッセージ
    Const END_MESSAGE = "更新完了"
    
    'No 初期化
    Dim cntNo As Long
    cntNo = 1
    '編集行 初期化
    Dim workRow As Long
    workRow = INDEX_START_ROW
    
    
    '処理前アクション
    StartAction SHEET_NAME_INDEX
    
    
    'シート表示状況 取得
    Dim visibleFlagDic As Object
    Set visibleFlagDic = SetVisibleFlagDic


    '全シート 表示
    AllSheetsVisible
    
    
    '「目次」を先頭に移動
    Sheets(SHEET_NAME_INDEX).Move before:=Sheets(1)
    
    
    'シート数 取得
    Dim ThisBookName As String
    ThisBookName = ThisWorkbook.Name
    Dim sheetCount As Long
    sheetCount = GetSheetCount(ThisBookName)
    
    
    '既存データ 削除
    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
    
    
    'オートフィルタ
    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
    
    
    '表示倍率：100％
    ZoomSet 100
    
    
    '処理後アクション
    EndAction SHEET_NAME_INDEX, END_MESSAGE


End Sub


'***** 他ブックの目次更新 *****
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


'***** シート切り出し *****
Sub ExportSheets()

    '行数
    Const TARGET_FOLDER_PATH_ROW = 3
    Const TARGET_FILE_NAME_ROW = 5
    Const START_SHEET_NAME_ROW = 10
    '列数
    Const TARGET_FOLDER_PATH_COL = 3
    Const TARGET_FILE_NAME_COL = 3
    Const NO_COL = 1
    Const SHEET_NAME_COL = 2
    Const RESULT_COL = 3
    '関数
    Const RETURN_INDEX_FORMULA = _
        "= IFERROR(HYPERLINK(""#'目次'!B"" & MATCH(RIGHT(CELL(""filename"", A1), LEN(CELL(""filename"", A1)) - FIND(""]"", CELL(""filename"", A1))), 目次!B:B, 0), ""戻る""), """")"
    '文言
    Const END_MESSAGE = "切り出し完了"
    Const EMPTY_MESSAGE = "シート名を記入してください"

    '編集行 初期化
    Dim workRow As Long
    workRow = START_SHEET_NAME_ROW
    'シート名連番 初期化
    Dim sheetNum As Long
    sheetNum = 0
    
    
    '処理前アクション
    StartAction SHEET_NAME_EXPORT_SHEET, False
    
    
    '最大行
    Dim maxRow As Long
    maxRow = GetMaxRow(SHEET_NAME_EXPORT_SHEET, SHEET_NAME_COL)
    '保存先のフォルダパス
    Dim targetFolderPath As String
    targetFolderPath = Cells(TARGET_FOLDER_PATH_ROW, TARGET_FOLDER_PATH_COL).Value
    '対象ファイル名
    Dim targetFileName As String
    targetFileName = Cells(TARGET_FILE_NAME_ROW, TARGET_FILE_NAME_COL).Value & EXCEL_EXTENSION
    
    
    'シート名カウント
    Dim sheetNameCount As Long
    
    If maxRow >= START_SHEET_NAME_ROW Then
        sheetNameCount = WSF_COUNTA(START_SHEET_NAME_ROW, maxRow, SHEET_NAME_COL) - 1
    Else
        sheetNameCount = 0
    End If
    
    Dim sheetNames() As String
    Dim arrayCnt As Long
    ReDim sheetNames(sheetNameCount)
    arrayCnt = UBound(sheetNames)
    
    
    'シート名 格納
    Dim i As Long
    
    If arrayCnt > 0 Then
        For i = 0 To arrayCnt
            sheetNames(i) = _
                FormatSheetName(WSF_TEXT(sheetNum, "00") & "_" & Cells(workRow, SHEET_NAME_COL).Value)
            '同名回避
            If SheetExistCheck(ThisWorkbook.Name, sheetNames(i)) = True Then
                sheetNames(i) = Left(sheetNames(i), MAX_SHEET_NAME_NUM - 3) & "(2)"
            End If
            '編集行 更新
            workRow = workRow + 1
            'シート連番 更新
            sheetNum = sheetNum + 1
        Next i
    Else
        MsgBox EMPTY_MESSAGE
        Exit Sub
    End If
    

    '切り出し先ブック 準備
    Dim checkFullPath As String
    Dim exportBookName As String
    
    checkFullPath = targetFolderPath & DELIMITER_BS & targetFileName
    
    If Dir(checkFullPath) = "" Then
        Workbooks.Add
        exportBookName = ActiveWorkbook.Name
    Else
        Workbooks.Open checkFullPath
        exportBookName = SplitFileName(checkFullPath)
    End If

    ThisWorkbook.Activate
    
    
    'シート追加
    Dim sheetName As Variant

    For Each sheetName In sheetNames
        Worksheets.Add after:=Worksheets(Worksheets.Count) 'シート追加
        ActiveSheet.Name = sheetName 'シート名 変更
    Next
    
    
    '「目次」シート追加
    '不要な場合はコメントアウト ===============================
    If SheetExistCheck(exportBookName, SHEET_NAME_INDEX) <> True Then
        With ThisWorkbook.Sheets(SHEET_NAME_INDEX_TMP)
            .Visible = True
            .Copy before:=Workbooks(exportBookName).Sheets(1)
            .Visible = False
            Workbooks(exportBookName).Sheets(SHEET_NAME_INDEX_TMP).Name _
                = SHEET_NAME_INDEX
         End With
         ThisWorkbook.Activate
    End If
    '================================================
    
    
    'アラート停止
    Application.DisplayAlerts = False
    
    
    'シート移動
    Dim sName As Variant
    
    For Each sName In sheetNames
        
        If SheetExistCheck(exportBookName, sName) <> True Then
            
            With Workbooks(exportBookName)
                ThisWorkbook.Sheets(sName).Copy after:=.Sheets(.Worksheets.Count)
                '不要な場合はコメントアウト ===============================
                '「戻る」更新
                .Sheets(sName).Range("A1").Value = RETURN_INDEX_FORMULA
                '================================================
            End With
            
            'コピー元シート 削除
            ThisWorkbook.Activate
            Sheets(sName).Delete
        End If
    
    Next

    
    '（新規ブックの場合）オープン時に作成されるシート 削除
    If Dir(targetFolderPath & DELIMITER_BS & exportBookName) = "" Then
        DeleteDefaultSheet exportBookName
    End If
    
    Workbooks(exportBookName).Sheets(1).Activate
    

    'アラート再開
    Application.DisplayAlerts = True
    
    
    '保存
    SaveCase targetFolderPath, exportBookName, targetFileName
    

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

End Sub


'***** 資材リスト 取得 *****
'◆メイン処理
Sub GetFolderAndFileList()

    '行数
    Const SEARCH_PATH_ROW = 3
    Const START_LIST_ROW = 5
    Const START_SUBFOLDER_ROW = 6
    '列数
    Const SEARCH_PATH_COL = 3
    Const START_LIST_COL = 3
    '終了メッセージ
    Const END_MESSAGE = "出力完了"
    
    
    '処理前アクション
    StartAction SHEET_NAME_FOLDER_AND_FILE_LIST, False
    
    
    'クリア処理
    ClearOldMaterialsList START_LIST_ROW, START_LIST_COL
    
    
    '対象フォルダパス 取得
    Dim targetFolder As String
    targetFolder = Cells(SEARCH_PATH_ROW, SEARCH_PATH_COL).Value
    
    
    '起点 出力
    ActiveSheet.Hyperlinks.Add _
        anchor:=Cells(START_LIST_ROW, START_LIST_COL), _
        Address:=targetFolder
    
    
    Dim fso As Object
    Dim folderObject As Object
    Set fso = CreateObject(FILE_SYSTEM_OBJECT)
    Set folderObject = fso.getfolder(targetFolder)
    
    
    'サブフォルダ 取得
    GetSubFolders folderObject, targetFolder, START_SUBFOLDER_ROW, START_LIST_COL
    
    
    'オブジェクト開放
    Set folderObject = Nothing
    Set fso = Nothing
    
    
    '処理後アクション
    EndAction SHEET_NAME_FOLDER_AND_FILE_LIST, END_MESSAGE


End Sub


'◆ファイル・サブフォルダ一覧化
Sub GetSubFolders(targetObj As Variant, ByVal targetFolder As String, targetRow As Long, targetCol As Long)


    Dim targetFile As Variant
    Dim fileLevel As Long
    
    
    'ファイル 一覧化
    For Each targetFile In targetObj.Files
        
        fileLevel = UBound(Split(Replace(targetFile.Path, targetFolder, ""), DELIMITER_BS))
        Cells(targetRow, targetCol + fileLevel) = targetFile.Name
        
        LineDraw targetRow, targetCol, fileLevel
        
        ActiveSheet.Hyperlinks.Add _
            anchor:=Cells(targetRow, targetCol + fileLevel), _
            Address:=targetFile.Path

        targetRow = targetRow + 1
    
    Next
    
    
    Dim targetSubFolder As Variant
    Dim subFolderLevel As Long
    
    
    'サブフォルダ 一覧化
    For Each targetSubFolder In targetObj.subfolders
        
        subFolderLevel = UBound(Split(Replace(targetSubFolder.Path, targetFolder, ""), DELIMITER_BS))
        Cells(targetRow, targetCol + subFolderLevel) = targetSubFolder.Name
        
        LineDraw targetRow, targetCol, subFolderLevel
        
        ActiveSheet.Hyperlinks.Add _
            anchor:=Cells(targetRow, targetCol + subFolderLevel), _
            Address:=targetSubFolder.Path
        
        targetRow = targetRow + 1
        
        '再帰呼出
        GetSubFolders targetSubFolder, targetFolder, targetRow, targetCol
    
    Next

End Sub


'◆罫線描画
Sub LineDraw(targetRow, targetCol, targetLevel)
    
    '縦線
    Const VERTICAL_LINE = "│"

    '描画処理
    Dim i As Long
    For i = targetCol + targetLevel - 1 To targetCol Step -1
        If i = targetCol + targetLevel - 1 Then
            Cells(targetRow, i) = ChrW(&H23BF)
        Else
            Cells(targetRow, i) = VERTICAL_LINE
        End If
        Cells(targetRow, i).HorizontalAlignment = xlCenter
    Next

End Sub


'◆既存データ 削除
Sub ClearOldMaterialsList(ByVal startListRow As Long, ByVal startListCol As Long)
    
    '対象セルから”最終セル”までを削除
    Range( _
        Cells(startListRow, startListCol), _
        ActiveCell.SpecialCells(xlLastCell) _
    ).Clear

End Sub


'***** CSV 取込 *****
Sub ImportCSV()

    '行数
    Const TARGET_FOLDER_ROW = 4
    Const IMPORT_DEST_FILE_ROW = 7
    Const IMPORT_DEST_SHEET_ROW = 8
    Const IMPORT_DEST_CELL_ROW = 9
    Const IMPORT_DEST_CELL_COL = 10
    Const START_RESULT_ROW = 13
    '列数
    Const NO_COL = 1
    Const IMPORT_RESULT_COL = 2
    Const SETTING_COL = 3
    '文言
    Const SEARCH_NAME = "*"
    Const END_MESSAGE = "取込み終了"

    '取り込んだファイル数
    Dim fileCount As Long
    fileCount = 1
    '対象行
    Dim workRow As Long
    workRow = START_RESULT_ROW
    '検索用ファイル名
    Dim tmpCsvName As String
    tmpCsvName = SEARCH_NAME & CSV_EXTENSION


    '対象フォルダパス 取得
    Dim targetFolder As String
    targetFolder = Cells(TARGET_FOLDER_ROW, SETTING_COL).Value
    
    
    'ファイルパス（1件目）
    Dim fileName As String
    Dim fullPath As String
    fileName = Dir(targetFolder & DELIMITER_BS & tmpCsvName)
    fullPath = targetFolder & DELIMITER_BS & fileName
    Workbooks.Open fullPath
    ThisWorkbook.Sheets(SHEET_NAME_CSV_IMPORT).Activate

    'ファイルパス（2件目以降）
    Do While fileName <> ""
        Cells(workRow, NO_COL).Value = fileCount
        Cells(workRow, IMPORT_RESULT_COL).Value = fullPath
        Workbooks.Open fullPath
        ThisWorkbook.Sheets(SHEET_NAME_CSV_IMPORT).Activate
        '更新
        fileCount = fileCount + 1
        workRow = workRow + 1
        fileName = Dir()
        fullPath = targetFolder & DELIMITER_BS & fileName
    Loop


    EndAction SHEET_NAME_CSV_IMPORT, END_MESSAGE

End Sub

Module2

Option Explicit

'■ ■ ■　よく使う処理　■ ■ ■

'***** 処理前アクション *****
'機能：処理開始前にExcelの描画を止める（任意）
Sub StartAction(ByVal sheetName As String, Optional ByVal ScreenUpdateFlag As Boolean = True)

    ThisWorkbook.Activate
    
    '描画停止
    If ScreenUpdateFlag = False Then
        Application.ScreenUpdating = ScreenUpdateFlag
    End If
    
    '対象シート 有効化
    Worksheets(sheetName).Activate

End Sub


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

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

End Sub


'***** デフォルトシート 削除 *****
'機能：ブックを開いたときに作成されるシートを削除する。
Sub DeleteDefaultSheet(ByVal bookName As String, Optional ByVal alertFlag As Boolean = True)

    '削除するシート名
    Const DELETE_SHEET_NAME_1 = "Sheet1"
    
    'アラート OFF
    If alertFlag = False Then
        Application.DisplayAlerts = False
    End If
    
    'シート削除
    With Workbooks(bookName)
        .Sheets(DELETE_SHEET_NAME_1).Delete '※削除したいシート分、実行する。
    End With
    
    'アラート再開
    If alertFlag = False Then
        Application.DisplayAlerts = True
    End If

End Sub


'***** 表示倍率 変更 *****
'機能: 指定した表示倍率に変更する｡
Sub ZoomSet(ByVal zoomPercentage As Long)

    '表示倍率 変更
    ActiveWindow.ZOOM = zoomPercentage

End Sub


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

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

End Function


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

    GetSheetCount = Workbooks(targetBookName).Sheets.Count

End Function


'***** 対象範囲 データ削除 *****
'機能：対象範囲の値のみを削除する。
Sub ClearContents(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) _
    ).ClearContents

End Sub


'***** 数式コピー（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 SplitFileName(ByVal targetFullPath As String, Optional ByVal splitDelimiter As String = "\") As String

    Dim delimiterPos As Long
    delimiterPos = InStrRev(targetFullPath, splitDelimiter)
    
    SplitFileName = Mid(targetFullPath, delimiterPos + 1)

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


'***** COUNTA関数 使用 *****
'機能：COUNTA関数の結果を返す。
Function WSF_COUNTA(ByVal startRow As Long, ByVal endRow As Long, ByVal startCol As Long, Optional ByVal endCol As Long = 0) As Long
    
    Dim workCol As Long
    
    If endCol = 0 Then
        workCol = startCol
    Else
        workCol = endCol
    End If
    
    WSF_COUNTA = _
        Application.WorksheetFunction.CountA( _
            Range(Cells(startRow, startCol), Cells(endRow, workCol)) _
        )

End Function


'***** シート名 整形 *****
'機能：対象文字列からシート名禁則文字を除外する（対象が32文字以上の場合、左から31文字を抜き出す）
Function FormatSheetName(ByVal targetSheetNaem As String) As String
    
    Dim sheetNameNGList As Variant
    Dim ngStr As Variant
    Dim tmpName As String
    tmpName = targetSheetNaem
    
    sheetNameNGList = Split(SHEET_NAME_NG_LIST, DELIMITER_C)
    
    For Each ngStr In sheetNameNGList
        tmpName = Replace(tmpName, ngStr, "")
    Next
    
    FormatSheetName = Left(tmpName, MAX_SHEET_NAME_NUM)

End Function


'***** TEXT関数 使用 *****
'機能：TEXT関数の結果を返す。
Function WSF_TEXT(ByVal targetNum As Long, ByVal textFormat As String) As String
    
    
    WSF_TEXT = Application.WorksheetFunction.Text(targetNum, textFormat)
    
End Function


'***** 場合分け保存 *****
'機能：対象ファイルが存在する場合は上書き保存、新規の場合は名前をつけて保存する。
Sub SaveCase(ByVal targetFolderPath As String, ByVal targetFileName As String, Optional ByVal tmpName As String = "")
    
    Dim saveName As String
    
    If tmpName = "" Then
        saveName = targetFileName
    Else
        saveName = tmpName
    End If
        
    Dim targetPath As String
    targetPath = targetFolderPath & DELIMITER_BS & saveName
    
    Workbooks(targetFileName).Activate
    
    If Dir(targetPath) = "" Then
        ActiveWorkbook.SaveAs targetPath
    Else
        ActiveWorkbook.Save
    End If
    
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

ThisWorkbook

Option Explicit

'***** 「戻る」追加 *****
'機能：新規シート作成時、目次に戻る関数を追加する。
Private Sub Workbook_NewSheet(ByVal Sh As Object)

    Const RETURN_INDEX_FORMULA = _
        "= IFERROR(HYPERLINK(""#'目次'!B"" & MATCH(RIGHT(CELL(""filename"", A1), LEN(CELL(""filename"", A1)) - FIND(""]"", CELL(""filename"", A1))), 目次!B:B, 0), ""戻る""), """")"

    ActiveSheet.Cells(1, 1).Formula = RETURN_INDEX_FORMULA

End Sub


'***** 目次表示 *****
'機能：ブックを開いたときに「目次」シートを表示する。
Private Sub Workbook_Open()
    
    'シート数 取得
    Dim sheetCount As Long
    sheetCount = ThisWorkbook.Sheets.Count
    
    Dim i As Long
    
    For i = 1 To sheetCount
        Sheets(i).Activate
        
        'Ctrl + HOMEの位置にカーソル移動
        With ActiveWindow
            .ActiveSheet.Cells(.SplitRow + 1, .SplitColumn + 1).Activate
        End With
        
        '表示倍率 100％
        ActiveWindow.ZOOM = 100
    
    Next i
    
    Sheets(1).Activate
    
End Sub