マクロ

Excelで文字列検索するマクロ

Option Explicit

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

' なし

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

    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 doTargetFiles(fileNames)
    
    ' ★ConcreateProcess側の処理の呼び出し（呼び出し先のProcedure側ではツールごとの固有の実装を行う）
    Call 後処理(wsMainSheet)
    
    MsgBox "処理が終了しました。（処理時間：" & get処理時刻() & ")"

End Sub

' *********************************************************************************************************************
' * 機能　：対象ファイルの処理を行う。
' * 引数　：varArray 配列
' * 戻り値：判定結果（1:配列/0:空の配列/-1:配列ではない）
' *********************************************************************************************************************
'
Function doTargetFiles(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)
        
        ' ★ConcreateProcess側の処理の呼び出し（呼び出し先のProcedure側ではツールごとの固有の実装を行う）
        unDealTargetSheetFlag = dealTargetWorkbook(fileName, targetWB, results)
        
        If False = unDealTargetSheetFlag Then
            Dim i As Integer
            For i = 1 To targetWB.Worksheets.Count ' シートの数分ループする
            
                Set targetSheet = targetWB.Worksheets(i)
                
                ' ★ConcreateProcess側の処理の呼び出し（呼び出し先のProcedure側ではツールごとの固有の実装を行う）
                Call dealTargetSheet(fileName, targetSheet, results)
                
            Next i
            
        End If
        
        Dim ファイルCLOSE方法区分値 As Long
        
        ' ★ConcreateProces側の処理の呼び出し（呼び出し先のProcedure側ではツールごとの固有の実装を行う）
        ファイル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
        
    ' ★ConcreateProcess側の処理の呼び出し（呼び出し先のProcedure側ではツールごとの固有の実装を行う）
    ' 実行結果の編集（結果のマージ、並び替え、フィルタリング当）
    Call editResults(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
            
            ' ★ConcreateProcess側の処理の呼び出し（呼び出し先のProcedure側ではツールごとの固有の実装を行う）
            Call setStyle(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 TITLE_NAME_BY_SEARCH_WORD = "▼検索ワード"

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

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

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

' 処理した件数
Dim resultCount As Long

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

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

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

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

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

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

End Function

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


End Function

' *********************************************************************************************************************
' 機能　：検出されたファイルの1シートごとに行いたい処理を実装する
' *********************************************************************************************************************
'
Function dealTargetSheet(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
    
    ' 検索文言リスト分ループ
    For Each searchArg In searchArgList
    
        ' 検索文言がない場合、次の検索文言を処理する
        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)                ' 結果保持の配列作成
            results(0, resultCount) = searchArg                         ' 検索文言
            results(1, resultCount) = FSO.GetParentFolderName(fileName) ' フォルダ名
            results(2, resultCount) = FSO.GetFileName(fileName)         ' ファイル名
            results(3, resultCount) = targetSheet.Name                  ' シート名
            results(4, resultCount) = FoundCell.Address(False, False)   ' 座標
            results(5, resultCount) = "セル"                            ' セル／オートシェイプ
            results(6, resultCount) = FoundCell.Value                   ' 文字列
            resultCount = resultCount + 1
            
            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
                
                    ' 結果を格納する
                    Call reDimResult(RESULT_COL_LENGTH, results)                ' 結果保持の配列作成
                    results(0, resultCount) = searchArg                         ' 検索文言
                    results(1, resultCount) = FSO.GetParentFolderName(fileName) ' フォルダ名
                    results(2, resultCount) = FSO.GetFileName(fileName)         ' ファイル名
                    results(3, resultCount) = targetSheet.Name                  ' シート名
                    results(4, resultCount) = ShapesInfoList(i, 7)              ' 座標
                    results(5, resultCount) = "オートシェイプ"                  ' セル／オートシェイプ
                    results(6, resultCount) = textValue                         ' 文字列
                    resultCount = resultCount + 1
                End If
            Next i
        End If
        
ContinueBySearchArg:

    Next
    
End Function

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


End Function

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

End Function

' *********************************************************************************************************************
' 機能　：ファイルに出力した後の実行結果を編集したい場合に実装する（ハイパーリンクの設定等）
' *********************************************************************************************************************
'
Sub setStyle(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

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

' なし

Option Explicit

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

'パスのデリミタ
Public Const PATH_DELIMITER = "\"

' ファイル名、拡張子のデリミタ
Public Const FILE_DELIMITER = "."

' ファイル操作情報
Public Type ファイル操作情報
    フルパス_ファイル名 As String
    フルパス As String
    親ディレクトリまでのフルパス As String
    対象ディレクトリ名 As String
    対象ファイル名 As String
    対象ファイル情報() As String
End Type

' 対象の拡張子（モジュール）
Public Const FILE_EXTENSION_OF_MODULE = "bas,cls,frm"

' ファイルCLOSE状態区分
Public Enum ファイルCLOSE方法区分
    保存しないで閉じる = 0
    保存して閉じる = 1
    保存しないで閉じない = 2
    保存して閉じない = 3
    処理中断 = 99
End Enum

' ---------------------------------------------------------------------------------------------------------------------
' 変数
' ---------------------------------------------------------------------------------------------------------------------

' ルートパス作成済フラグ
Private rootPathMaked As Boolean

' #####################################################################################################################
' #
' # アクセサ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' * 機能　：ルートパス作成済みフラグを設定する
' *********************************************************************************************************************
'
Public Function getRootPathMaked() As Boolean
    getRootPathMaked = rootPathMaked
End Function

' *********************************************************************************************************************
' * 機能　：ルートパス作成済みフラグを取得する
' *********************************************************************************************************************
'
Public Function setRootPathMaked(isMaked As Boolean)
    rootPathMaked = isMaked
End Function

' #####################################################################################################################
' #
' # ファイル操作ユーティリティ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' * 機能　：パス（パス＆ファイル）の存在チェック
' * 引数　：directoryPath パス（または、パス＆ファイル）
' * 戻り値：チェック結果（パス存在時は1、ファイル存在時は2、パスもファイルも存在しない場合は-1）
' *********************************************************************************************************************
'
Function isDirectoryExist(directoryPath As String) As Long

    Dim FSO
    
    Set FSO = CreateObject("Scripting.FileSystemObject")
    
    If True = FSO.FileExists(directoryPath) Then
        isDirectoryExist = 2
    ElseIf True = FSO.FolderExists(directoryPath) Then
        isDirectoryExist = 1
    Else
        isDirectoryExist = -1
    End If
        
End Function

' *********************************************************************************************************************
' * 機能　：パス配下の階層全てのディレクトリを処理する
' * 引数　：directoryPath パス
' * 戻り値：実行結果（カレントディレクトリを含む、配下のディレクトリ名の配列
' *********************************************************************************************************************
'
Function doRepeat(ByVal directoryPath As String, ByVal fileExtensions As Variant, _
    ByRef fileNames() As String, Optional ByVal recursive As Boolean = False)
    
    ' 検索結果
    Dim buf As String, msg As String, dirName As Variant
    
    ' 配下のパス情報
    Dim directoryPathBySub As String
    directoryPathBySub = directoryPath
    
    ' 直下のディレクトリ存在可否フラグ
    Dim isExistDir As Boolean
    isExistDir = False
    
    Dim dirNames() As String
    
    Dim resultArray As Variant
    
    If "" <> directoryPath Then
        ' ディレクトリ移動
        ChDir directoryPath
        
        ' -------------------------------------------------------------------------------------------------------------
        ' 直下のファイル名を全て取得
        ' -------------------------------------------------------------------------------------------------------------
        Call getFileNames(directoryPath, fileExtensions, fileNames)
        
        If recursive Then
        
            ' ---------------------------------------------------------------------------------------------------------
            ' 直下のディレクトリ名を全て取得
            ' ---------------------------------------------------------------------------------------------------------
            dirNames = getDirNames(directoryPath)
            
            ' ---------------------------------------------------------------------------------------------------------
            ' 取得したディレクトリ名1つずつ再帰的に処理する。
            ' ---------------------------------------------------------------------------------------------------------
            If Not Not dirNames Then
                For Each dirName In dirNames
                    Call doRepeat(dirName, fileExtensions, fileNames, True)
                Next
            End If
            
        End If
        
    End If
    
End Function

' *********************************************************************************************************************
' * 機能　：パス直下のファイル名を全て取得
' * 引数　：directoryPath パス
' * 戻り値：実行結果（カレントディレクトリ直下のディレクトリ名の配列。）
' *********************************************************************************************************************
'
Function getFileNames(directoryPath As String, fileExtensions As Variant, ByRef fileNames() As String)

    Dim fileName As String, msg As String
    
    Dim fileNameSize As Integer
    
    Dim fileExtension As Variant
    
    ' ディレクトリ移動
    ChDir directoryPath
    
    ' -----------------------------------------------------------------------------------------------------------------
    ' 直下のファイル名を全て取得
    ' -----------------------------------------------------------------------------------------------------------------
    fileName = Dir(directoryPath & "\" & "*.*")
    
    Do While fileName <> ""
    
        ' ファイル名取得
        For Each fileExtension In fileExtensions
            If InStr(1, UCase(fileName), UCase(fileExtension)) > 0 Then
            
                ' フルパス＆ファイル名を追加格納。
                Call 一次配列に値を追加(fileNames, directoryPath & "\" & fileName)
                Exit For
        
            End If
        Next
    
        fileName = Dir()
    Loop

End Function

' *********************************************************************************************************************
' * 機能　：パス直下のディレクトリ名を全て取得
' * 引数　：directoryPath パス
' * 戻り値：実行結果（カレントディレクトリ直下のディレクトリ名の配列。）
' *********************************************************************************************************************
'
Function getDirNames(directoryPath As String) As String()
    Dim buf As String
    
    Dim dirNames() As String
    
    ' ディレクトリ移動
    ChDir directoryPath
    
    buf = Dif(directoryPath & "\" & "*.*", vbDirectory)
    Do While buf <> ""
        ' ディレクトリ名取得
        If GetAttr(directoryPath & "\" & buf) And vbDirectory Then
            If buf <> "." And buf <> ".." Then
            
                ' ディレクトリ名を追加格納。
                Call 一次元配列に値を追加(dirNames, directoryPath & "\" & buf)
                
            End If
        End If
        buf = Dir()
        
    Loop
    
    getDirNames = dirNames

End Function


' *********************************************************************************************************************
' * 機能　：対象ディレクトリを作成する（対象パスが未存在、作成ディレクトリ名が存在した場合は処理中断）
' *********************************************************************************************************************
'
Function ディレクトリ作成(ByVal ルートパス As String, ByVal 処理日時 As String, ByVal 相対パス As String)

    Dim dirCheck As Long
    
    ' ルートパスの存在チェック
    dirCheck = isDirectoryExist(CStr(ルートパス & 処理日時))
    ' 対象パスが未設定の場合（ルートパス作成時）
    If "" = 相対パス Then
        ' 処理日時が設定済の場合、ルートパスが作成済であれば処理中断とする
        If "" <> 処理日時 Then
            If 0 < dirCheck And False = getRootPathMaked() Then
                MsgBox "以下のディレクトリは既に存在するため処理を中断します。" + Chr(10) + "「" + ルートパス & 処理日時 + "」"
                End
            End If
        End If
    End If

    ' ディレクトリ作成
    dirCheck = isDirectoryExist(CStr(ルートパス & 処理日時 & PATH_DELIMITER & 相対パス))
    If 0 > dirCheck Then
        MkDir ルートパス & 処理日時 & PATH_DELIMITER & 相対パス
        Call setRootPathMaked(True)
    End If
    
End Function

Option Explicit

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

Public Const TITLE_NAME_PREFIX = "▼"

' ---------------------------------------------------------------------------------------------------------------------
' 変数
' ---------------------------------------------------------------------------------------------------------------------

Dim var開始時刻 As Variant

' #####################################################################################################################
' #
' # ログ系ユーティリティ
' #
' #####################################################################################################################

Sub log(ByVal strメッセージ As String)

    Debug.Print Format(Now(), "HH:mm:ss ") & strメッセージ

End Sub

' #####################################################################################################################
' #
' # ステータスバー操作系ユーティリティ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' * 機能　：ステータスバーに表示する処理時間を初期化する
' *********************************************************************************************************************
'
Sub init開始時刻()

    var開始時刻 = Now()
    
End Sub

' *********************************************************************************************************************
' * 機能　：処理時間の開始時刻を取得する
' *********************************************************************************************************************
'
Function get開始時刻()

    get開始時刻 = var開始時刻

End Function

' *********************************************************************************************************************
' * 機能　：処理時間を HH:mm:ss 形式で取得する
' *********************************************************************************************************************
'
Function get処理時刻()

    get処理時刻 = Format(Now() - var開始時刻, "HH:mm:ss")
    
End Function

' *********************************************************************************************************************
' * 機能　：ステータスバーに経過時間付でメッセージを表示する
' *********************************************************************************************************************
'
Sub setステータスバー(ByVal strメッセージ As String)

    If IsEmpty(var開始時刻) Then
        
        var開始時刻 = Now()
        
    End If
    
    Application.StatusBar = get処理時刻() & " " & strメッセージ

End Sub

' #####################################################################################################################
' #
' # ブック、シート操作系ユーティリティ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' * 機能　：引数で渡されたシート名以外のシートを削除する
' *********************************************************************************************************************
'
'
Function 不要シート削除(対象ブック情報 As Workbook, ByVal 残すシート名 As String)

    Dim 前状態 As Boolean
    前状態 = Application.DisplayAlerts
    
    Application.DisplayAlerts = False
    
    Dim ws As Worksheet
    
    For Each ws In 対象ブック情報.Worksheets
    
        If ws.Name <> 残すシート名 Then
            Worksheets(ws.Name).Delete
        End If
        
    Next ws
    
    Application.DisplayAlerts = 前状態
        
End Function


' #####################################################################################################################
' #
' # ダイアログ操作系ユーティリティ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' * 機能　：処理続行 or 中止確認ダイアログを表示する
' *********************************************************************************************************************
'
Function 処理続行判断(message As String)

    Dim rc As VbMsgBoxResult
    rc = MsgBox(message + Chr(10) + "処理を続行しますか？", vbYesNo, vbQuestion)
    
    If rc = vbYes Then
        MsgBox "処理を続けます", vbInformation
    Else
        MsgBox "処理を中止しました。", vbCritical
        
        ' マクロの実行中止
        End
    End If

End Function


' #####################################################################################################################
' #
' # オートシェイプ操作系ユーティリティ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' 機能名：対象シート上にあるオブジェクトおｎプロパティを取得する
' 戻り　：getShapesProperty as String(2, n)
'         (0, n)   type
'         (1, n)   name
'         (2, n)   TextFrame.Characters.text
'         (3, n)   Left
'         (4, n)   Top
'         (5, n)   Width
'         (6, n)   Height
'         (7, n)   TopLeftCell.Address(False, False)
'         (8, n)   TopLeftCell.row
'         (9, n)   TopLeftCell.Column
'         (10, n)  BottomRightCell.Address(False, False)
'         (11, n)  BottomRightCell.row
'         (12, n)  BottomRightCell.Column
'
' *********************************************************************************************************************
'
Function getShapesProperty(ByRef targetSheet As Worksheet, Optional ByVal objType As Long = -999, Optional ByVal formCtlType As Long = -999) As Variant

    Dim ret As Variant
    
    Dim i As Long
    Dim obj As Variant
    
    ' 配列の作成。
    i = 0
    For Each obj In targetSheet.Shapes
        ' FORMコントロールの場合
        If obj.Type = objType Then
            ' 渡されたフォームコントロールタイプが一致した場合、カウントアップ
            If obj.FormControlType = formCtlType Then
                i = i + 1
            End If
            
            ' 指定なし又は、それ以外のオートシェイプ
            ElseIf objType = -999 Or obj.Type = objType Then
                i = i + 1
            End If
    Next
        
    ' 対象のオートシェイプがみつかった場合のみ、そのオブジェクトの格納を行う。
    If 0 <> i Then
        ReDim ret(i - 1, 12)
        
        ' 配列の作成
        i = 0
        ' オブジェクト情報の設定
        For Each obj In targetSheet.Shapes
            
            ' formコントロールの場合
            If obj.Type = objType Then
                ' 渡されたフォームコrントロールタイプが一致した場合、値を取得する。
                If obj.FormControlType = formCtlType Then
                        
                    ret(i, 0) = obj.Type
                    ret(i, 1) = obj.AlternativeText
                        
                    ' TextFrameプロパティが使用できない（レイアウト枠がない）オブジェクトは除外
                    On Error Resume Next
                    ret(i, 2) = obj.ControlFormat.Value
                    ret(i, 3) = obj.Left
                    ret(i, 4) = obj.Top
                    ret(i, 5) = obj.Width
                    ret(i, 6) = obj.Height
                    ret(i, 7) = obj.TopLeftCell.Address(False, False)
                    ret(i, 8) = obj.TopLeftCell.Row
                    ret(i, 9) = obj.TopLeftCell.Column
                    ret(i, 10) = obj.Left.BottomRightCell.Address(False, False)
                    ret(i, 11) = obj.Left.BottomRightCell.Row
                    ret(i, 12) = obj.Left.BottomRightCell.Column
                        
                    i = i + 1
                End If
                    
            ' 指定なし又は、それ以外のオートシェイプなどの場合
            ElseIf objType = -999 Or obj.Type = objType Then
                
                ret(i, 0) = obj.Type
                ret(i, 1) = obj.AlternativeText
                        
                ' TextFrameプロパティが使用できない（レイアウト枠がない）オブジェクトは除外
                On Error Resume Next
                ret(i, 2) = obj.TextFrame.Characters.Text
                    
                ret(i, 3) = obj.Left
                ret(i, 4) = obj.Top
                ret(i, 5) = obj.Width
                ret(i, 6) = obj.Height
                ret(i, 7) = obj.TopLeftCell.Address(False, False)
                ret(i, 8) = obj.TopLeftCell.Row
                ret(i, 9) = obj.TopLeftCell.Column
                ret(i, 10) = obj.Left.BottomRightCell.Address(False, False)
                ret(i, 11) = obj.Left.BottomRightCell.Row
                ret(i, 12) = obj.Left.BottomRightCell.Column
                       
                i = i + 1
            End If
        Next
    End If
        
    getShapesProperty = ret
    
End Function

 


' #####################################################################################################################
' #
' # 配列操作系ユーティリティ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' 機能　：引数が配列か判定し、配列の場合は空かどうかも判定する
' 引数　：varArray 配列
' 戻り値：判定結果（1:配列/0:空の配列/-1：配列じゃない)
' *********************************************************************************************************************
'
Public Function IsArrayEx(varArray As Variant) As Long
On Error GoTo ERROR_

    If IsArray(varArray) Then
        IsArrayEx = IIf(UBound(varArray) >= 0, 1, 0)
    Else
        IsArrayEx = -1
    End If
    
    Exit Function
    
ERROR_:
    If Err.Number = 9 Then
        IsArrayEx = 0
    End If
End Function


' *********************************************************************************************************************
' 機能　：実行結果を保持する二次元配列変数を定義するFunction
' *********************************************************************************************************************
'
Function reDimResult(ByVal topLevelElementSize As Integer, ByRef results() As Variant)

    Select Case IsArrayEx(results)
        Case 1
            ' resultsが初期化済の場合
            ' 現在のレコード数 + 1行領域を確保
            ReDim Preserve results(topLevelElementSize, UBound(results, 2) + 1)
        Case 0
            ' resultsが1度も初期化されていない場合
            ' 1行領域を確保
            ReDim Preserve results(topLevelElementSize, 0)
    End Select
        
End Function

' *********************************************************************************************************************
' 機能　：一次元配列に新たな要素を追加する
' *********************************************************************************************************************
'
Function 一次配列に値を追加(ByRef valueList As Variant, ByVal 追加設定値 As String)

    ' ファイル名を取得する
    Select Case IsArrayEx(valueList)
        Case 1
            ReDim Preserve valueList(UBound(valueList) + 1)
        Case 0
            ReDim Preserve valueList(0)
    End Select
    
    ' 追加したリストに、設定値を格納。
    valueList(UBound(valueList)) = 追加設定値
    
End Function

' *********************************************************************************************************************
' 機能　：二次元配列の行と列を入れ替える
' *********************************************************************************************************************
'
Function 二次元配列行列逆転(ByRef var二次元配列 As Variant)

    Dim var逆転後配列 As Variant
    
    ReDim var逆転後配列( _
        LBound(var二次元配列, 2) To UBound(var二次元配列, 2), _
        LBound(var二次元配列) To UBound(var二次元配列))
        
    Dim i, j As Long
    
    For i = LBound(var二次元配列) To UBound(var二次元配列, 2)
        
        For j = LBound(var二次元配列) To UBound(var二次元配列)
            
            var逆転後配列(i, j) = var二次元配列(j, i)
            
        Next
    Next
    
    二次元配列行列逆転 = var逆転後配列
        
    
End Function


' #####################################################################################################################
' #
' # 装飾系ユーティリティ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' 機能　：対象セルにハイパーリンク数式を適用する
' *********************************************************************************************************************
'
Public Function editHYPERLINK数式( _
    ByVal strフォルダ名 As String, _
    ByVal strファイル名 As String, _
    ByVal strシート名 As String, _
    ByVal str座標 As String) As String
    
    editHYPERLINK数式 = _
        "=HYPERLINK(""[" & strフォルダ名 & "\" & strファイル名 & "]" & _
        strシート名 & "!" & str座標 & """,""" & str座標 & """)"
    
End Function
    
' *********************************************************************************************************************
' 機能　：対象セル範囲内で検索文字列に該当した文字列を赤太文字にする
' *********************************************************************************************************************
'
Function 検索該当文字の赤太文字化(prmRange As Range, prmTargetString As String)

    Dim txt As String
    Dim i, m As Integer
    Dim targetRange As Range
    
    If prmTargetString = "" Then
        Exit Function
    End If

    For Each targetRange In prmRange
        txt = targetRange.Value
        m = Len(prmTargetString)
        i = InStr(1, txt, prmTargetString)
        Do Until i = 0
            With prmRange.Characters(i, m)
                .Font.Bold = True
                .Font.ColorIndex = 3
            End With
            i = InStr(i + 1, txt, prmTargetString)
        Loop
    Next
    
    Set targetRange = Nothing
    
End Function

' #####################################################################################################################
' #
' # シート情報取得系ユーティリティ
' #
' #####################################################################################################################

' *********************************************************************************************************************
' 機能　：タイトル名指定でリスト値を取得
'         ※リスト値がなかった場合、配列の要素数1（値は空）が返却されます。
' *********************************************************************************************************************
'
Function タイトル名指定でリスト値を取得(titleName As String, targetSheet As Worksheet) As Variant

    Dim targetRangeList As Range
    Dim targetVariantList As Variant
    
    Set targetRangeList = タイトル名指定でリスト値のRange情報を取得(titleName, targetSheet)
    ' 配列か判定
    If targetRangeList.Count = 1 Then
        targetVariantList = Array(targetRangeList.Item(1).Value)
    Else
        targetVariantList = targetRangeList.Value
    End If
    
    タイトル名指定でリスト値を取得 = targetVariantList
    
End Function

' *********************************************************************************************************************
' 機能　：タイトル名指定でリスト値のRange情報を取得
'         ※リスト値がなかった場合、リスト値エリアの1行目（値は空）のRange情報が返却されます。
' *********************************************************************************************************************
'
Function タイトル名指定でリスト値のRange情報を取得(titleName As String, targetSheet As Worksheet) As Range

    ' 検索ヒット数
    Dim matchCount As Long
    Dim checkValue As String
    
    ' シート内にタイトル名が複数設定されていない事を確認する。
    matchCount = WorksheetFunction.CountIf(targetSheet.UsedRange, titleName)
    If 1 <> matchCount Then
        MsgBox "タイトル「" & titleName & "」が複数見つかったため、処理を中断しました。"
        End
    End If
    
    ' タイトル名のRange情報を取得
    Dim FoundCell As Range
    Set FoundCell = targetSheet.UsedRange.Find(what:=titleName, LookIn:=xlValues, _
        LookAt:=xlPart, MatchCase:=False, MatchByte:=False)
    Dim i, MaxRow, MaxCol As Long
    
    ' タイトルに対するリスト値を取得（空白行込み）
    With targetSheet
        With .Range(.Cells(FoundCell.Row, FoundCell.Column), .Cells(Rows.Count, FoundCell.Column))
            MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
            MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
        End With
    
        ' MaxRowを、空白行より一行↑のリスト値の行数に設定する。
        For i = 1 To (MaxRow - FoundCell.Row)
            checkValue = .Cells(FoundCell.Row + i, MaxCol).Value
            If "" = checkValue Or InStr(1, checkValue, TITLE_NAME_PREFIX) > 0 Then
                If 1 = i Then
                    Call 処理続行判断("タイトル名「" + titleName + "」に対するリスト値が設定されていません。")
                    MaxRow = FoundCell.Row + 1
                Else
                    MaxRow = FoundCell.Row + i - 1
                End If
                    Exit For
            End If
        Next
        
        ' リスト値を返却
        Set タイトル名指定でリスト値のRange情報を取得 = _
            targetSheet.Range(.Cells((FoundCell.Row + 1), FoundCell.Column), .Cells(MaxRow, MaxCol))
        
    End With

End Function