テンプレート処理

Option Explicit

' ---------------------------------------------------------------------------------------------------------------------
' 定数
' ---------------------------------------------------------------------------------------------------------------------

' なし

' *********************************************************************************************************************
' * 機能　：マクロ呼び出し時（シートからの指定用）
' *********************************************************************************************************************

Sub マクロ開始()

    Call init開始時刻
    
    Dim wsMainSheet As Worksheet
    Dim fileCheck As Long
    
    ' タイトル名に対するリストの情報（Range情報）
    Dim currentDirPathRangeList As Range, currentDirPathRange As Range
    Dim subDirCheckBoxRangeList As Range, subDirCheckBoxRange As Range
    
    ' 処理対象のファイル名一覧（フルパス＆ファイル名）
    Dim fileNames() As String
    
    ' -----------------------------------------------------------------------------------------------------------------
    ' 初期化処理
    ' -----------------------------------------------------------------------------------------------------------------
    
    ' 処理対象の拡張子を設定する。
    Dim fileExtention As Variant
    fileExtention = Split(FILE_EXTENSION, ",")
    
    ' 固有処理（マクロ呼び出し元）側のシート情報を取得する。
    ' Set wsMainSheet = MainSheet
    Set wsMainSheet = ActiveSheet
    
    ' 固有処理（マクロ呼び出し元）側のパス情報を取得する。
    Set currentDirPathRangeList = タイトル名指定でリスト値のRange情報を取得(TITLE_NAME_BY_TARGET_DIR, wsMainSheet)
    Set subDirCheckBoxRangeList = タイトル名指定でリスト値のRange情報を取得(TITLE_NAME_BY_DO_SUB_DIR, wsMainSheet)
    
    ' ★ConcreateProcess側の処理の呼び出し（呼び出し先のProcedure側ではツールごとの固有の実装を行う）
    Call 全体前処理(wsMainSheet)


    ' -----------------------------------------------------------------------------------------------------------------
    ' パスの存在チェック
    ' -----------------------------------------------------------------------------------------------------------------

    With wsMainSheet

        Dim i As Long
        i = 0
        ' 対象ディレクトリ分ループ
        If Not (currentDirPathRangeList Is Nothing) Then
            For Each currentDirPathRange In currentDirPathRangeList
            
                ' ディレクトリまたは、ファイルの存在チェック
                fileCheck = isDirectoryExist(CStr(currentDirPathRange.Value))
                
                If 0 > fileCheck Then
                    MsgBox "以下のパスは存在しません。" + Chr(10) + "「" + currentDirPathRange.Value + "」"
                    End
                End If
                i = i + 1
            Next
        End If
    End With

    ' -----------------------------------------------------------------------------------------------------------------
    ' ファイル名の収集
    ' -----------------------------------------------------------------------------------------------------------------

    Call setステータスバー("対象ファイル集計中...")
    
    With ActiveSheet
    
        i = 1
        '対象ディレクトリ分ループ
        If Not (currentDirPathRangeList Is Nothing) Then
            For Each currentDirPathRange In currentDirPathRangeList
            
                '指定の値がファイルの場合、その値をリストに追加し、ディレクトリの場合は、ファイル名の一覧を動的に取得して追加する。
                fileCheck = isDirectoryExist(CStr(currentDirPathRange.Value))
                If 2 = fileCheck Then
                    ' 指定の値がファイルだった場合、その値をリストに追加
                    ' フルパス＆ファイル名を追加格納。
                    Call 一次配列に値を追加(fileNames, CStr(currentDirPathRange.Value))
                Else
                    
                    ' ＜オートシェイプ情報の取得＞
                    Dim shapesCount As Long
                    Dim checkBoxChecked As Variant
                    Dim topLeftCellRow As Variant, topLeftCellColumn As Variant
            
                    ' オートシェイプ（チェックボックス）情報を取得。
                    Dim ShapesInfoList As Variant
                    ShapesInfoList = getShapesProperty(wsMainSheet, msoFormControl, xlCheckBox)
                    
                    ' 対象セル行のチェックボックスのチェック状態を取得（boolean形式で）
                    checkBoxChecked = False
                    
                    If IsArrayEx(ShapesInfoList) > 0 Then
                        For shapesCount = LBound(ShapesInfoList) To UBound(ShapesInfoList)
                            topLeftCellRow = ShapesInfoList(shapesCount, 8)
                            topLeftCellColumn = ShapesInfoList(shapesCount, 9)
                            
                            ' 取得したチェックボックスが以下の条件に一致した場合、対象と判断する。
                            ' ・チェックボックスの行が、処理中の対象ディレクトリの行と一致。
                            ' ・チェックボックスの列が、タイトルの列と一致。
                            If Not IsEmpty(topLeftCellRow) And topLeftCellRow = currentDirPathRange.Row _
                                And topLeftCellColumn = subDirCheckBoxRangeList.Item(0).Column Then
                                
                                ' チェックボックス値を取得する。
                                If 1 = ShapesInfoList(shapesCount, 2) Then
                                    checkBoxChecked = True
                                End If
                                Exit For
                                
                            End If
                        Next shapesCount
                        
                    End If
                    
                    ' 現在のディレクトリ配下のファイル名を取得
                    Call doRepeat(currentDirPathRange, fileExtention, fileNames, checkBoxChecked)
                
                End If
                
                i = i + 1
            Next
            
        End If
        
    End With
    
    ' -----------------------------------------------------------------------------------------------------------------
    ' ファイル処理メソッドの呼び出し
    ' -----------------------------------------------------------------------------------------------------------------
    
    Call ファイル処理(fileNames)
    
    ' ★実装処理側の処理の呼び出し（呼び出し先のProcedure側ではツールごとの固有の実装を行う）
    Call 全体後処理(wsMainSheet)
    
    MsgBox "処理が終了しました。（処理時間：" & get処理時刻() & ")"

End Sub

' *********************************************************************************************************************
' * 機能　：対象ファイルの処理を行う。
' * 引数　：varArray 配列
' * 戻り値：判定結果（1:配列/0:空の配列/-1:配列ではない）
' *********************************************************************************************************************
'
Function ファイル処理(fileNames() As String)

    ' ファイル名の一覧が空だった場合、当Functionを中断する。
    If 1 > IsArrayEx(fileNames) Then
        MsgBox "処理対象ファイルが存在しません。"
        Exit Function
    End If
    
    Dim FSO
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Dim fileName As Variant
    Dim targetWB As Workbook
    Dim targetSheet As Worksheet
    
    Dim index As Long, total As Long
    
    Dim defaultSaveFormat As Long
    defaultSaveFormat = Application.defaultSaveFormat
    
    ' シート毎の処理呼び出し不要フラグ
    Dim unDealTargetSheetFlag As Boolean
    
    ' 処理結果保持用
    Dim results() As Variant
    
    index = 1
    total = UBound(fileNames) + 1
    
    Application.DisplayAlerts = False ' ファイルを開く際の警告を無効
    Application.ScreenUpdating = False ' 画面表示更新を無効
    
    For Each fileName In fileNames
    
        ' -------------------------------------------------------------------------------------------------------------
        ' 対象ブックを開いて、全シート分の処理を行う。
        ' -------------------------------------------------------------------------------------------------------------

        Call setステータスバー("(" & index & "/" & total & ")" & FSO.GetFileName(fileName))
        index = index + 1
        
        Set targetWB = Workbooks.Open(fileName, UpdateLinks:=0, IgnoreReadOnlyRecommended:=False)
        
        ' ★実装処理側の処理の呼び出し（呼び出し先のProcedure側ではツールごとの固有の実装を行う）
        unDealTargetSheetFlag = ブックOPEN後処理(fileName, targetWB, results)
        
        If False = unDealTargetSheetFlag Then
            Dim i As Integer
            For i = 1 To targetWB.Worksheets.Count ' シートの数分ループする
            
                Set targetSheet = targetWB.Worksheets(i)
                
                ' ★実装処理側の処理の呼び出し（呼び出し先のProcedure側ではツールごとの固有の実装を行う）
                Call シート毎処理(fileName, targetSheet, results)
                
            Next i
            
        End If
        
        Dim ファイルCLOSE方法区分値 As Long
        
        ' ★実装処理側の処理の呼び出し（呼び出し先のProcedure側ではツールごとの固有の実装を行う）
        ファイルCLOSE方法区分値 = ブックCLOSE前処理(fileName, targetWB, results)
        
        If ファイルCLOSE方法区分値 = ファイルCLOSE方法区分.保存しないで閉じる Then
            targetWB.Close
        ElseIf ファイルCLOSE方法区分値 = ファイルCLOSE方法区分.保存して閉じる Then
            targetWB.Save
            targetWB.Close
        ElseIf ファイルCLOSE方法区分値 = ファイルCLOSE方法区分.保存しないで閉じない Then
            
        ElseIf ファイルCLOSE方法区分値 = ファイルCLOSE方法区分.保存して閉じない Then
            targetWB.Save
        ElseIf ファイルCLOSE方法区分値 = ファイルCLOSE方法区分.処理中断 Then
            End
        End If
    Next
        
    ' ★実装処理側の処理の呼び出し（呼び出し先のProcedure側ではツールごとの固有の実装を行う）
    ' 実行結果の編集（結果のマージ、並び替え、フィルタリング当）
    Call 実行結果内容編集処理(results)
    
    If Not Not results Then
    
        If UBound(results, 2) <> 0 Then
        
            ' ファイルの保存形式をexcel2007形式（.xlsx)に変更
            Application.defaultSaveFormat = xlOpenXMLWorkbook
            
            Set targetWB = Workbooks.Add
            
            ' 当ブックにシート「雛形」が用意されている場合、指定ブックの先頭にコピーした後、
            ' シート名を「処理結果」に変更する。（ない場合は新規作成ブックのsheet1を利用）
            Call 雛形シートコピー(targetWB)
            
            ' 結果貼り付け行の取得。
            ' A列に値が設定されている行を、表題欄としてその行数を取得する
            Dim MaxRow As Integer
            With targetWB.ActiveSheet.UsedRange
                MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
            End With
            ' 結果貼り付け行の設定。
            MaxRow = MaxRow + 1
            
            ' 結果貼り付け
            targetWB.ActiveSheet.Range(Cells(MaxRow, 1), Cells(UBound(results, 2) + 2, UBound(results) + 1)) = 二次元配列行列逆転(results)
            
            Dim MaxCol As Integer
            ' 書式コピー
            With targetWB.ActiveSheet
                MaxRow = .UsedRange.Find("*", , xlFormulas, xlByRows, xlPrevious).Row
                MaxCol = .UsedRange.Find("*", , xlFormulas, xlByColumns, xlPrevious).Column
                
                .Range(.Cells(2, 1), .Cells(2, MaxCol)).Copy
                .Range(.Cells(2 + 1, 1), .Cells(MaxRow, MaxCol)).PasteSpecial (xlPasteFormats)
            End With
            
            ' ★実装処理側の処理の呼び出し（呼び出し先のProcedure側ではツールごとの固有の実装を行う）
            Call 実行結果書式編集処理(targetWB.ActiveSheet)
            
            ' "A1"を選択状態にする
            targetWB.ActiveSheet.Cells(1, 1).Select
            
            ' シート名「処理結果」以外のシートを削除する
            Call 不要シート削除(targetWB, RESULT_SHEET_NAME)
            
        Else
            
            MsgBox "処理結果は0件です。"
        End If
        
    Else
    
        MsgBox "処理結果は0件です。"
        
    End If
            
    Application.DisplayAlerts = True
    Application.ScreenUpdating = True
    
    Application.StatusBar = False
    
    ' ファイルの保存形式を元の状態に戻す
    Application.defaultSaveFormat = defaultSaveFormat
    
    If Not Not results Then
        If UBound(results, 2) <> 0 Then
            targetWB.Activate
        End If
    End If

End Function


' *********************************************************************************************************************
' * 機能　：当ブックのシート「雛形」を指定ブックの先頭にコピーした後、
' * 　　　　シート名を「処理結果」に変更する
' *********************************************************************************************************************
'
Sub 雛形シートコピー(targetWB As Workbook)

    Dim myWorkBook  As String
    Dim newWorkBook As String
    Dim targetSheet As Worksheet
    Dim sheetName   As String
    
    ' マクロを実行中のブック名を取得
    myWorkBook = ThisWorkbook.Name
    
    ' 新規ブック名を取得
    newWorkBook = targetWB.Name
    
    ' マクロ実行時のブックをアクティブにする
    Workbooks(myWorkBook).Activate
    
    ' シート「雛形」があった場合、指定ブックにコピー（一番前に挿入）する
    Dim i As Integer
    For i = 1 To Workbooks(myWorkBook).Worksheets.Count ' シートの数分ループする
    
        Set targetSheet = Workbooks(myWorkBook).Worksheets(i)
        
        If TEMPLATE_SHEET_NAME = targetSheet.Name Then
            Workbooks(myWorkBook).Sheets(TEMPLATE_SHEET_NAME).Copy _
            Before:=Workbooks(newWorkBook).Sheets(1)
        End If
        
    Next i
    
    ' マクロを実行中のブックをアクティブにする
    Workbooks(targetWB.Name).Sheets(TEMPLATE_SHEET_NAME).Activate
    ' シート名を「処理結果」に変更する
    Workbooks(targetWB.Name).Sheets(TEMPLATE_SHEET_NAME).Name = RESULT_SHEET_NAME
    
End Sub

実装処理

Option Explicit

' ---------------------------------------------------------------------------------------------------------------------
' 定数（共通）
' ---------------------------------------------------------------------------------------------------------------------

' タイトル名（共通）
Public Const TITLE_NAME_BY_TARGET_DIR = "▼ファイル"
Public Const TITLE_NAME_BY_DO_SUB_DIR = "▼配下のディレクトリも対象"

' 雛形シートコピー用（共通）
Public Const TEMPLATE_SHEET_NAME = "雛形"
Public Const RESULT_SHEET_NAME = "処理結果"

' 対象の拡張子
Public Const FILE_EXTENSION = "xls,xlsx,xlsm"

' 処理結果シートデータ貼付け部の列数
Private Const RESULT_COL_LENGTH = 6

' ---------------------------------------------------------------------------------------------------------------------
' 定数（個別）
' ---------------------------------------------------------------------------------------------------------------------

' タイトル文字列（対象シート固有）
Private Const TITLE_NAME_BY_SEARCH_WORD = "▼検索ワード"

' 検索文言リスト
Private varSearchArgList As Variant

' 処理した件数
Dim lngResultCount As Long

' #####################################################################################################################
' #
' # テンプレートメソッド(テンプレート処理から呼び出されるメソッド）
' #
' # 1. 全体前処理()            処理実行前に1度だけ実行したい処理を実装する
' # 2. ブックOPEN後処理()      検出されたファイルのブックごとに行いたい処理を実装する
' #                            （シート毎の処理呼び出しが不要かの判定値(boolean)を返却する）
' # 3. シート毎処理()          検出されたファイルの1シートごとに行いたい処理を実装する
' # 4. ブックCLOSE前処理()     検出されたファイルのブックごとに行いたい後処理を実装する
' # 5. 実行結果内容編集処理()  実行結果について、ファイルに出力する前に編集したい場合に実装する（重複の削除、ソート等）
' # 6. 実行結果書式編集処理()  ファイルに出力した後の実行結果を編集したい場合に実装する（ハイパーリンクの設定等）
' # 7. 全体後処理()            処理実行後に1度だけ実行したい処理を実装する
' #
' #####################################################################################################################
'

' *********************************************************************************************************************
' 機能　：固有処理側の前処理
' *********************************************************************************************************************
'
Function 全体前処理(targetSheet As Worksheet)

    ' -----------------------------------------------------------------------------------------------------------------
    ' 初期化処理
    ' -----------------------------------------------------------------------------------------------------------------

    ' 処理した件数の初期化
    ' resultCount = 0

    ' -----------------------------------------------------------------------------------------------------------------
    ' 前処理
    ' -----------------------------------------------------------------------------------------------------------------

    ' 処理対象の検索文言リストを取得する。
    ' 固有処理（マクロの呼び出し元）側のパス情報を取得する。
    varSearchArgList = タイトル名指定でリスト値を取得(TITLE_NAME_BY_SEARCH_WORD, targetSheet)

End Function

' *********************************************************************************************************************
' 機能　：検出されたファイルのブックごとに行いたい処理を実装する（シート毎の処理呼び出しが不要かの判定値(boolean)を返却する）
' *********************************************************************************************************************
'
Function ブックOPEN後処理(fileName As Variant, targetWB As Workbook, ByRef results() As Variant) As Boolean


End Function

' *********************************************************************************************************************
' 機能　：検出されたファイルの1シートごとに行いたい処理を実装する
' *********************************************************************************************************************
'
Function シート毎処理(fileName As Variant, targetSheet As Worksheet, ByRef results() As Variant)

    Dim FSO
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    Dim searchArg As Variant
    Dim targetWB As Workbook
    
    Dim ShapesInfoList As Variant
    Dim ShapesInf As Variant
    
    ' -----------------------------------------------------------------------------------------------------------------
    ' 処理
    ' -----------------------------------------------------------------------------------------------------------------
    
    ' 指定された検索文言リストの文字列の検索結果を収集する。
    
    ' 対象シートの検索結果を「FoundAddr」に格納する。
    Dim firstAddress As String
    Dim FoundCell As Range
    
    Dim lngResultCount As Long ' 結果件数
    
    ' 検索文言リスト分ループ
    For Each searchArg In varSearchArgList
    
        ' 検索文言がない場合、次の検索文言を処理する
        If "" = searchArg Then
        
            GoTo ContinueBySearchArg
        End If
        
        ' ＜セルの検索＞
        Set FoundCell = targetSheet.UsedRange.Find(what:=searchArg, LookIn:=xlValues, _
            LookAt:=xlPart, MatchCase:=False, MatchByte:=False)
            
        ' セルへの検索結果がない場合
        If FoundCell Is Nothing Then
            ' 検索結果がなかった場合次の検索文言を処理する
            GoTo GotoCellSearchEnd
        End If
        
        firstAddress = FoundCell.Address ' 検索結果のアドレスを配列に格納
        
        Do
            ' 結果を格納する
            Call reDimResult(RESULT_COL_LENGTH, results)                ' 結果保持の配列作成
            lngResultCount = UBound(results, 2)
            
            results(0, lngResultCount) = searchArg                         ' 検索文言
            results(1, lngResultCount) = FSO.GetParentFolderName(fileName) ' フォルダ名
            results(2, lngResultCount) = FSO.GetFileName(fileName)         ' ファイル名
            results(3, lngResultCount) = targetSheet.Name                  ' シート名
            results(4, lngResultCount) = FoundCell.Address(False, False)   ' 座標
            results(5, lngResultCount) = "セル"                            ' セル／オートシェイプ
            results(6, lngResultCount) = FoundCell.Value                   ' 文字列
            
            Set FoundCell = targetSheet.UsedRange.FindNext(After:=FoundCell)
            
        Loop Until FoundCell.Address = firstAddress
        
GotoCellSearchEnd:

        ' ＜オートシェイプの検索＞
        ShapesInfoList = getShapesProperty(targetSheet)
        Dim i As Integer
        Dim textValue As Variant
        i = 0
        
        ' 検索文言リスト分ループ
        If Not IsEmpty(ShapesInfoList) Then
            For i = LBound(ShapesInfoList) To UBound(ShapesInfoList)
                textValue = ShapesInfoList(i, 2)
                If Not IsEmpty(textValue) And InStr(textValue, searchArg) Then
  
                    lngResultCount = UBound(results, 2)
                
                    ' 結果を格納する
                    Call reDimResult(RESULT_COL_LENGTH, results)                   ' 結果保持の配列作成
                    results(0, lngResultCount) = searchArg                         ' 検索文言
                    results(1, lngResultCount) = FSO.GetParentFolderName(fileName) ' フォルダ名
                    results(2, lngResultCount) = FSO.GetFileName(fileName)         ' ファイル名
                    results(3, lngResultCount) = targetSheet.Name                  ' シート名
                    results(4, lngResultCount) = ShapesInfoList(i, 7)              ' 座標
                    results(5, lngResultCount) = "オートシェイプ"                  ' セル／オートシェイプ
                    results(6, lngResultCount) = textValue                         ' 文字列
                End If
            Next i
        End If
        
ContinueBySearchArg:

    Next
    
End Function

' *********************************************************************************************************************
' 機能　：検出されたファイルのブックごとに行いたい後処理を実装する
' *********************************************************************************************************************
'
Function ブックCLOSE前処理(fileName As Variant, targetWB As Workbook, ByRef results() As Variant) As Long


End Function

' *********************************************************************************************************************
' 機能　：実行結果について、ファイルに出力する前に編集したい場合に実装する（重複の削除、ソート等）
' *********************************************************************************************************************
'
Function 実行結果内容編集処理(ByRef var変換元() As Variant) As Variant

End Function

' *********************************************************************************************************************
' 機能　：ファイルに出力した後の実行結果を編集したい場合に実装する（ハイパーリンクの設定等）
' *********************************************************************************************************************
'
Sub 実行結果書式編集処理(ByRef targetSheet As Worksheet)

    Dim i, MaxRow, MaxCol As Long
    
    With targetSheet
        MaxRow = .UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
        MaxCol = .UsedRange.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
        
        ' 書式コピー
        .Range(Cells(2, 1), Cells(2, MaxCol)).Copy
        .Range(Cells(2 + 1, 1), Cells(MaxRow, MaxCol)).PasteSpecial (xlPasteFormats)
        
        For i = 2 To MaxRow
            ' ハイパーリンク設定
            Dim strHyperLink As String
            strHyperLink = editHYPERLINK数式(.Cells(i, 2), .Cells(i, 3), .Cells(i, 4), .Cells(i, 5))
            
            .Range(.Cells(i, 5), .Cells(i, 5)).Value = strHyperLink
            
            ' 赤文字
            Call 検索該当文字の赤太文字化(.Range(Cells(i, 7), Cells(i, 7)), Cells(i, 1))
            
        Next
    End With
          
End Sub

' *********************************************************************************************************************
' 機能　：処理実行後に1度だけ実行したい処理を実装する
' *********************************************************************************************************************
'
Function 全体後処理(targetSheet As Worksheet)

End Function

' #####################################################################################################################
' #
' # テンプレートメソッド以外のメソッド
' #
' #####################################################################################################################
'

' なし