2018-10-23

cls試験データシート

Option Explicit

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

Const cnst上限レコード取得数 = 1000 ' 環境に合わせて増減

Const cnst試験データ開始行 = 5
Const cnstヘッダ行数 = 5
Const cnstテーブル物理名記載列 = 4

Const cnstテーブル名記載行idx = 1
Const cnstデータ開始行idx = 2
Const cnstデータ終了行idx = 3
Const cnstデータ終了列idx = 4

' Private oraconn As New ADODB.Connection
Private oraconn As Object

' *********************************************************************************************************************
' 機能：コンストラクタ
' *********************************************************************************************************************
'
Public Sub Class_Initialize()

    Set oraconn = CreateObject("ADODB.Connection")
    
End Sub

' *********************************************************************************************************************
' 機能：シート上、オープン状態のテーブルのレコードをDBに取得しに行く
' *********************************************************************************************************************
'
Public Function getレコード(ByRef wb前回実行結果 As Workbook) As Workbook

    If ActiveSheet.Range("A1") <> "凡例" Then
    
        Call log("想定外のシートが対象となっているためProcedureを終了します。")
        
        Exit Function
    End If
    
    Dim obj設定シート As cls設定シート: Set obj設定シート = New cls設定シート
    
    ' データベースに接続する（必要な値は設定シートから取得）
    oraconn.ConnectionString = obj設定シート.getConnectionString
    
    ' On Error GoTo occurError
    
    oraconn.Open
    
    If executeCountSQL Then ' ユーザが件数を確認し続行した場合のみデータを取得
    
        Set getレコード = executeSQL(wb前回実行結果)

    End If
    
    oraconn.Close
    Set oraconn = Nothing
    
    Exit Function
    
occurError:

    Dim txtエラーメッセージ As String
    
    txtエラーメッセージ = txtエラーメッセージ & "エラー番号：" & Err.Number & vbCrLf
    txtエラーメッセージ = txtエラーメッセージ & Err.Description & vbCrLf
    txtエラーメッセージ = txtエラーメッセージ & "ヘルプファイル名：" & Err.HelpContext & vbCrLf
    txtエラーメッセージ = txtエラーメッセージ & "プロジェクト名：" & Err.Source
    
    MsgBox txtエラーメッセージ
    
    End
    
End Function
    
' *********************************************************************************************************************
' 機能：COUNTのSQL発行を行う。
'       カウントの結果を参照したユーザが、処理を中断した場合、FALSEを返す
' *********************************************************************************************************************
'
Private Function executeCountSQL() As Boolean

    ' Dim rs As ADODB.Recordset
    Dim rs As Object
    Set rs = CreateObject("ADODB.Recordset")
    
    Dim obj試験データテーブル() As cls試験データテーブル
    obj試験データテーブル = getテーブル座標情報
    
    With ActiveSheet
    
        Dim i As Long
        
        For i = LBound(obj試験データテーブル) To UBound(obj試験データテーブル)
        
            ' ---------------------------------------------------------------------------------------------------------
            ' SQL文の作成
            ' ---------------------------------------------------------------------------------------------------------
            
            ' ヘッダ部分が非表示の場合はスキップする
            If obj試験データテーブル(i).Hidden() Then
            
                GoTo continue
            End If
        
            Dim strQuery As String
            strQuery = obj試験データテーブル(i).createSELECT文From複数行()
            
            ' ---------------------------------------------------------------------------------------------------------
            ' SQL文の発行
            ' ---------------------------------------------------------------------------------------------------------
            
            Dim txtCountQuery As String
            txtCountQuery = obj試験データテーブル(i).createCount文(strQuery)
            
            log ("発行するSQL：" & txtCountQuery)
            Set rs = oraconn.Execute(txtCountQuery)
            
            obj試験データテーブル(i).setDBCount結果 (rs.Fields("COUNT"))
    
continue:
    
        Next i
        
    End With
    
    ' レコードセットをクローズする
    rs.Close
    Set rs = Nothing
    
    ' COUNTモードで実行した場合、取得予定の件数を利用者に通知する。
    ' 尚、件数が上限を超えるような場合は、利用者にその旨を通知し、処理を打ち切る。
    
    Dim txtCountList As String
    Dim lngレコード総数 As Long: lngレコード総数 = 0
    
    For i = LBound(obj試験データテーブル) To UBound(obj試験データテーブル)
    
        If Not obj試験データテーブル(i).Hidden Then
        
            txtCountList = txtCountList & _
                obj試験データテーブル(i).getテーブル論理名 & _
                "：" _
                & obj試験データテーブル(i).getDBCount結果 & " 件" & vbCrLf
                
            lngレコード総数 = lngレコード総数 + obj試験データテーブル(i).getDBCount結果
        End If
        
    Next i
    
    Dim txtMsg As String
    
    If lngレコード総数 <= cnst上限レコード取得数 Then
    
        txtMsg = "総件数 " & lngレコード総数 & " 件のレコードを結果として取得します。" _
            & vbCrLf & vbCrLf & txtCountList
            
        If MsgBox(txtMsg, vbOKCancel) <> vbOK Then
        
            executeCountSQL = False
            Exit Function
        End If
    
    Else
    
        txtMsg = "総件数（" & lngレコード総数 _
            & " 件）が上限件数（" & cnst上限レコード取得数 & " 件）を超えています。" _
            & "条件を見直して下さい。" _
            & vbCrLf & vbCrLf & txtCountList
            
        MsgBox (txtMsg)
        
        executeCountSQL = False
        Exit Function
        
     End If
        
    executeCountSQL = True
        
End Function


' *********************************************************************************************************************
' 機能：COUNTのSQL発行を行う。
'       カウントの結果を参照したユーザが、処理を中断した場合、FALSEを返す
' *********************************************************************************************************************
'
Private Function executeSQL(ByRef wb前回実行結果 As Workbook) As Workbook

    Dim wb実行元ブック As Workbook
    Set wb実行元ブック = ActiveWorkbook
    
    Dim rs As Object
    Set rs = CreateObject("ADODB.Recordset")
    
    Dim obj試験データテーブル() As cls試験データテーブル
    obj試験データテーブル = getテーブル座標情報
    
    Dim lng出力最終行 As Long
    lng出力最終行 = 5
    
    ' ブックの準備
    If wb前回実行結果 Is Nothing Then
    
        Dim wb実行結果 As Workbook
        Set wb実行結果 = Workbooks.Add
        
        wb実行元ブック.ActiveSheet.Copy Before:=wb実行結果.Sheets(1)
        
    Else
        Set wb実行結果 = wb前回実行結果
        
        wb実行元ブック.ActiveSheet.Copy After:=wb実行結果.Sheets(wb実行結果.Sheets.Count)
    
    End If
    
    Dim txt実行結果シート名 As String
    txt実行結果シート名 = Format(Now(), "yyyymmdd_HHnnss")
    
    wb実行結果.Sheets(wb実行元ブック.ActiveSheet.Name).Name = txt実行結果シート名
    
    If wb前回実行結果 Is Nothing Then
        Call 不要シート削除(wb実行結果, txt実行結果シート名)
    End If
    
    wb実行結果.ActiveSheet.Range("A" & lng出力最終行, ActiveCell.SpecialCells(xlLastCell)).Delete
    wb実行結果.ActiveSheet.Outline.ShowLevels RowLevels:=2
    
    wb実行結果.ActiveSheet.Rows.Ungroup
    
    ' wb実行結果.AvtiveSheet.Range("F1").Value = "" ' マクロ用のガイドつぶし
    
    wb実行元ブック.Activate
    
    With ActiveSheet
    
        Dim i As Long
        
        For i = LBound(obj試験データテーブル) To UBound(obj試験データテーブル)
        
            ' ---------------------------------------------------------------------------------------------------------
            ' SQL文の作成
            ' ---------------------------------------------------------------------------------------------------------
            
            ' ヘッダ部分が非表示の場合はスキップする
            If obj試験データテーブル(i).Hidden() Then
            
                GoTo continue
            End If
            
            
            Dim txtQuery As String
            txtQuery = obj試験データテーブル(i).createSELECT文From複数行()
            
            ' ---------------------------------------------------------------------------------------------------------
            ' SQL文の発行
            ' ---------------------------------------------------------------------------------------------------------
                        
            Dim txtCountQuery As String
            txtCountQuery = obj試験データテーブル(i).createCount文(txtQuery)
            
            ' log("発行するSQL：" & txtCountQuery)
            Set rs = oraconn.Execute(txtCountQuery)
            
            obj試験データテーブル(i).setDBCount結果 (rs.Fields("COUNT"))
            
            rs.Close
            Set rs = Nothing
            
            Set rs = oraconn.Execute(txtQuery)
            
            obj試験データテーブル(i).copy枠Toクリップボード
            
            With wb実行結果.ActiveSheet.Range("A" & lng出力最終行)
            
                .PasteSpecial ' データ行をコピー
                
            End With
            
            With wb実行結果.ActiveSheet.Range("F" & lng出力最終行)
            
                .ClearComments
                .AddComment ("-- 結果取得時のSQL" & vbCrLf _
                    & txtQuery) ' テーブル論理名のセルにデータ取得に使用したSQLをコメントで残す
                .Comment.Shape.TextFrame.AutoSize = True
                
                Dim lngデータ行数 As Long
                
                If obj試験データテーブル(i).getDBCount結果 = 0 Then
                
                    lngデータ行数 = 1
                Else
                    lngデータ行数 = obj試験データテーブル(i).getDBCount結果
                End If
                
                ' 件数の情報を書き込み
                .Value = "=COUNTA(B" & lng出力最終行 + cnstヘッダ行数 & ":B" & lng出力最終行 + cnstヘッダ行数 + lngデータ行数 & ")"
                
            End With
            
            lng出力最終行 = lng出力最終行 + cnstヘッダ行数
            
            ' 行のクリア（記入された文字＋セルの背景色）
            wb実行結果.ActiveSheet.Rows(lng出力最終行).ClearContents
            
            With wb実行結果.ActiveSheet.Rows(lng出力最終行).Interior
                .Pattern = xlNone
                .TintAndShade = 0
                .PatternTintAndShade = 0
            End With
            
            If obj試験データテーブル(i).getDBCount結果 > 0 Then
            
                ' 行の罫線をコピー
                wb実行結果.ActiveSheet.Rows(lng出力最終行).Copy
                
                wb実行結果.ActiveSheet.Rows(lng出力最終行 & ":" _
                    & lng出力最終行 + obj試験データテーブル(i).getDBCount結果() - 1).PasteSpecial
                    
                    Dim var取得結果 As Variant
                    ReDim var取得結果( _
                        1 To obj試験データテーブル(i).getDBCount結果, _
                        1 To rs.Fields.Count)
                        
                    Dim j As Long
                    
                    For j = 1 To UBound(var取得結果)
                    
                        If rs.EOF Then
                        
                            Exit For
                        End If
                        
                        Dim k As Long
                        
                        For k = 1 To rs.Fields.Count
                        
                            var取得結果(j, k) = rs.Fields(k - 1)
                            
                        Next k
                         
                        rs.MoveNext
                        
                    Next j
                    
                    With wb実行結果.ActiveSheet
                    
                        .Range(.Cells(lng出力最終行, 2), _
                            .Cells(lng出力最終行 + UBound(var取得結果) - 1, UBound(var取得結果, 2) + 1)) = var取得結果
                            
                    End With
            
                    lng出力最終行 = lng出力最終行 + obj試験データテーブル(i).getDBCount結果() + 1
                    
                Else
                
                    lng出力最終行 = lng出力最終行 + 2 ' 空枠＋余白で2行
                    
                End If
                
continue:

            Next i
            
        End With
        
        ' レコードセットをクローズする
        rs.Close
        Set rs = Nothing
        
        Set executeSQL = wb実行結果
            
            
End Function

' *********************************************************************************************************************
' 機能：対象シートのINSERT文生成
' *********************************************************************************************************************
'
Public Function 対象シートINSERT文作成(ByRef obj対象シート As Worksheet) As String

    If obj対象シート.Range("A1") <> "凡例" Then
        Exit Function
    End If
    
    Dim obj試験データテーブル() As cls試験データテーブル
    obj試験データテーブル = getテーブル座標情報
    
    Dim txt結果 As String
    
    Dim i As Long
    
    For i = LBound(obj試験データテーブル) To UBound(obj試験データテーブル)
    
        txt結果 = txt結果 & obj試験データテーブル(i).createInsert文(obj対象シート)
        
continue:

    Next i
    
    対象シートINSERT文作成 = txt結果
    
End Function

' *********************************************************************************************************************
' 機能：テーブルのグループごとの表示/非表示を制御する
' *********************************************************************************************************************
'
Public Sub 表示非表示の切替(Optional ByVal txtテーブル名 As String = "*マスタ")

    Dim varテーブル座標情報 As Variant
    varテーブル座標情報 = getテーブル座標情報
    
    Dim i As Long
    
    ActiveSheet.Outline.ShowLevels RowLevels:=2
    ActiveSheet.Rows.Ungroup
    
    For i = LBound(varテーブル座標情報) To UBound(varテーブル座標情報)
    
        If Not ActiveSheet.Range("A" & varテーブル座標情報(i, 1)) Like txtテーブル名 Then
        
            Range(Cells(varテーブル座標情報(i, 1) + 1, 1), Cells(varテーブル座標情報(i, 3), 1)).Rows.Group
            
        End If
    Next i
    
    ActivceSheet.Outline.ShowLevels RowLevels:=1
    
    For i = LBound(varテーブル座標情報) To UBound(varテーブル座標情報)
    
        If ActiveSheet.Range("A" & varテーブル座標情報(i, 1)) Like txtテーブル名 Then
        
        
            Range(Cells(varテーブル座標情報(i, 1) + 1, 1), Cells(varテーブル座標情報(i, 3), 1)).Row.Group
        
        End If
    Next i

End Sub


' *********************************************************************************************************************
' 機能：引数で指定されたブックの後方2シートを比較し、差分に関する情報を後方のシートに付与する。
' *********************************************************************************************************************
'
Public Sub edit実行結果差分(ByRef wb引数実行結果 As Workbook)

    wb引数実行結果.Activate
    
    
    Dim ws実行前, ws実行後 As Worksheet
    
    Set ws実行前 = wb引数実行結果.Sheets(wb引数実行結果.Sheets.Count - 1)
    Set ws実行後 = wb引数実行結果.Sheets(wb引数実行結果, Sheets, Count)
    
    Dim obj実行前データテーブル() As cls試験データテーブル
    Dim obj実行後データテーブル() As cls試験データテーブル

    ws実行前.Activate
    obj実行前データテーブル = getテーブル座標情報()
    
    ws実行後.Activate
    obj実行後データテーブル = getテーブル座標情報()
    
    Dim i, j As Long
    i = UBound(obj実行後データテーブル)
    j = UBound(obj実行前データテーブル)
    
    ' 実行後を軸に、実行前とのマッチングを行っていく
    Do While (UBound(obj実行後データテーブル) <= i Or LBound(obj実行前データテーブル) <= j)
    
        If obj実行後データテーブル(i).getテーブル物理名 <> obj実行前データテーブル(j).getテーブル物理名 Then
        
            j = j - 1
            
            If j < UBound(obj実行前データテーブル) Then
            
                Exit Sub ' 実行前テーブルが存在しなくなった場合、終了
            End If
            
        Else
            Call compareテーブル(obj実行前データテーブル(j), obj実行後データテーブル(i))
            i = i - 1
            j = j - 1
            
        End If
        
    Loop

End Sub

' =====================================================================================================================
' Privateメソッド
' =====================================================================================================================
'

' *********************************************************************************************************************
' 機能：テーブル内容の比較を行う
' *********************************************************************************************************************
'
Private Sub compareテーブル( _
    ByRef obj実行前データテーブル As cls試験データテーブル, ByRef obj実行後データテーブル As cls試験データテーブル)
    
    If obj実行前データテーブル.get件数() = 0 And obj実行後データテーブル.get件数() = 0 Then
    
        Exit Sub ' 両方0件の場合、何もしない
    End If
        
    Dim i, j As Long
    
    With obj実行後データテーブル
    
        i = .データ終了行
        j = obj実行前データテーブル.データ終了行
        
        Do While (i >= .データ開始行 Or j >= obj実行前データテーブル.データ開始行)
        
            ' データがない行を読み飛ばす
            If .get主キー項目連結文字列(i) = "" Then
            
                i = i - 1
                GoTo continue
                
            ElseIf obj実行前データテーブル.get主キー項目連結文字列(j) = "" Then
            
                j = j - 1
                GoTo continue
                
            End If
            
            ' いずれかのデータを読み切っている場合
            If j < obj実行前データテーブル.データ開始行 Then
                
                Call log差異("読切追加", j, obj実行前データテーブル, i, obj実行後データテーブル)
                obj実行後データテーブル.edit選択行強調 (i)
                
                With .対象シート.Cells(i, 1)
                    .AddComment ("■追加")
                    .Comment.Shape.TextFrame.AutoSize = True
                End With
                
                i = i - 1
                
                GoTo continue
                
            ElseIf i < .データ開始行 Then
            
                Call log差異("読切削除", j, obj実行前データテーブル, i, obj実行後データテーブル)
                obj実行後データテーブル.add空行 (obj実行後データテーブル.データ開始行)
                obj実行後データテーブル.edit選択行網掛 (obj実行後データテーブル.データ開始行)
            
                With .対象シート.Cells(obj実行後データテーブル.データ開始行, 1)
                
                    .AddComment ("■削除" & vbCrLf _
                        & Join(obj実行前データテーブル.get主キー(), " ") & vbLf _
                        & Join(obj実行前データテーブル.get主キー(j), " "))
                        
                    .Comment.Shape.TextFrame.AutoSize = True
                    
                End With
                
                j = j - 1
                
                GoTo continue
                
            End If
            
            ' まだ、いずれのデータも残っている場合
            If .get主キー項目連結文字列(i) = obj実行前データテーブル.get主キー項目連結文字列(j) Then
            
                Call log差異("比較一致", j, obj実行前データテーブル, i, obj実行後データテーブル)
            
                Call compareレコード(obj実行前データテーブル, obj実行前データテーブル, j, i)
                
                i = i - 1
                j = j - 1
                
            ElseIf StrComp(.get主キー項目連結文字列(i), obj実行前データテーブル.get主キー項目連結文字列(j), _
                vbBinaryCompare) > 0 Then
                
                Call log差異("比較追加", j, obj実行前データテーブル, i, obj実行後データテーブル)
                obj実行後データテーブル.edit選択行強調 (i)
                
                With .対象シート.Cells(i, 1)
                    .AddComment ("■追加")
                    .Comment.Shape.TextFrame.AutoSize = True
                End With
                
                i = i - 1
                
            Else
                Call log差異("比較削除", j, obj実行前データテーブル, i, obj実行後データテーブル)
                obj実行後データテーブル.add空行 (i + 1)
                obj実行後データテーブル.edit選択行網掛 (i + 1)
                
                With .対象シート.Cells(i + 1, 1)
                
                    .AddComment ("■削除" & vbCrLf _
                        & Join(obj実行前データテーブル.get主キー(), " ") & vbCrLf _
                        & Join(obj実行前データテーブル.get主キー(), " "))
                        
                    .Comment.Shape.TextFrame.AutoSize = True
                
                End With
                
                j = j - 1
                
            End If
continue:
        Loop
        
    End With
    
End Sub


' *********************************************************************************************************************
' 機能：デバッグ用の差異情報出力メソッド
' *********************************************************************************************************************
'
Private Sub compareレコード( _
    ByRef obj実行前データテーブル As cls試験データテーブル, _
    ByRef obj実行後データテーブル As cls試験データテーブル, _
    ByVal lng実行前対象行 As Long, ByVal lng実行後対象行 As Long)
    
    Dim txtコメント文字列 As String
    
    Dim txt変更前, txt変更後 As String
    
    Dim i As Long
    For i = 2 To obj実行前データテーブル.カラム終了列
    
        txt変更前 = obj実行前データテーブル.対象シート.Cells(lng実行前対象行, i)
        txt変更後 = obj実行後データテーブル.対象シート.Cells(lng実行後対象行, i)
        
        
        If txt変更前 <> txt変更後 Then
        
            Call obj実行後データテーブル.edit変更強調色(obj実行後データテーブル.Cells(lng実行後対象行, i))
            
            txtコメント文字列 = txtコメント文字列 & vbCrLf _
                & obj実行前データテーブル.getカラム論理名(i) & "：" & txt変更前 & " → " & txt変更後
        End If
    Next i
    
    If txtコメント文字列 <> "" Then
        With obj実行後データテーブル.対象シート.Cells(lng実行後対象行, 1)
        
            .AddComment ("■更新" & txtコメント文字列)
            .Comment.Shape.TextFrame.AutoSize = True
            
        End With
    End If
End Sub

' *********************************************************************************************************************
' 機能：デバッグ用の差異情報出力メソッド
' *********************************************************************************************************************
'
Private Sub log差異(ByVal txtメッセージ As String, _
    ByVal lng変更前対象行 As Long, ByRef obj実行前データテーブル As cls試験データテーブル, _
    ByVal lng変更後行番号 As Long, ByRef obj実行後データテーブル As cls試験データテーブル)
    
    log obj実行前データテーブル.getカラム論理名 & vbTab & txtメッセージ _
        & vbTab _
        & "変更前" & vbTab & lng変更前行番号 & "行目" & vbTab _
        & obj実行後データテーブル.get主キー項目連結文字列(lng変更前対象行) _
        & vbTab _
        & "変更後" & vbTab & lng変更後行番号 & "行目" & vbTab _
        & obj実行後データテーブル.get主キー項目連結文字列(lng変更後行番号)

End Sub

' *********************************************************************************************************************
' 機能：テーブルごとの座標情報を返却する
' *********************************************************************************************************************
'
Private Function getテーブル座標情報() As cls試験データテーブル()

    Dim lng最終行, lng最終列 As Long
    Dim varテーブル座標情報ワーク As Variant
    
    With ActiveSheet.UsedRange
        lng最終行 = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
        lng最終列 = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
    End With
    
    varテーブル座標情報ワーク = Range("A" & cnst試験データ開始行 & ":B" & lng最終行 + cnstヘッダ行数)
    
    Dim lngテーブル数 As Long
    lngテーブル数 = WorksheetFunction.CountA(Range("A" & cnst試験データ開始行 & ":A" & lng最終行))
    
    Dim obj試験データテーブル() As cls試験データテーブル
    ReDim obj試験データテーブル(1 To lngテーブル数)
    
    Dim i, index As Long: index = 0
    
    For i = 1 To UBound(varテーブル座標情報ワーク)
    
        ' テーブル名の列に値が設定されている場合
        If varテーブル座標情報ワーク(i, 1) <> "" Then
            
            index = index + 1
            
            Set obj試験データテーブル(index) = New cls試験データテーブル
            
            ' 実際の行番号を設定するため開始行分行数を加算
            Set obj試験データテーブル(index).対象シート = ActiveSheet
            obj試験データテーブル(index).setテーブル名記載行 (cnst試験データ開始行 + i - 1)
            
            If index > 1 Then
            
                ' テーブル名が見つかった場合、その２セル上を前テーブルの終了行とみなす
                obj試験データテーブル(index - 1).setデータ終了行 (obj試験データテーブル(index).getテーブル名記載行 - 2)
            End If
        
        End If
        
    Next i
    
    If index > 0 Then
    
        ' 最後のテーブルは、最終行の3行後を最終行とみなす
        obj試験データテーブル(index).setデータ終了行 (lng最終行 + 3)
        
    End If
    
    
    getテーブル座標情報 = obj試験データテーブル
    
End Function

2018-10-22

実装処理

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

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

' なし

2018-10-22

テンプレート処理

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

2018-10-02

Util

Attribute VB_Name = "Util"
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

' *********************************************************************************************************************
' * 機能　：確認ダイアログを表示
' *********************************************************************************************************************
'
Function 確認ダイアログ表示(messages() As String, Optional ByVal 処理続行確認ダイアログ表示フラグ As Boolean = True) As Long

    Dim dispMessage, message As Variant
    
    For Each message In messages
        dispMessage = dispMessage + message + Chr(10)
    Next
    
    Dim rc As VbMsgBoxResult
    rc = MsgBox(dispMessage, vbYesNoCancel + vbQuestion)
    
    If rc = vbCancel Then
        MsgBox "処理を中止しました", vbCritical
        ' マクロの実行中断
        End
    Else
        If True = 処理続行確認ダイアログ表示フラグ Then
            MsgBox "処理を続けます", vbInformation
        End If
    End If
    
    確認ダイアログ表示 = rc
    
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

' *********************************************************************************************************************
' 機能　：引数で指定された行が選択状態であるか判定する
' *********************************************************************************************************************
'
Function is選択状態(ByVal lng対象行 As Long)

    Dim rng As Range
    
    For Each rng In Selection.Rows
    
        If rng.Row = lng対象行 Then
        
            is選択状態 = True
            Exit Function
            
        End If
        
    Next rng
        
    is選択状態 = False


End Function

2017-08-30

マクロ下書（タスク算出）

Option Explicit

' タスクシート設定
Const lng開始行 As Long = 3

Dim var全体開始日 As Variant ' 全体の開始日
Const txt全体開始日アドレス As String = "B1"

' シート名
Const cnst休日シート名 As String = "休日"
Const cnst担当者シート名 As String = "担当者"

Const idx処理中日付 As Long = 1
Const idx工数 As Long = 2
Const idx1日あたり工数 As Long = 3
Const idx休日リスト As Long = 4

Dim txt休日リスト() As String

Dim lngID列, lng先行タスクID列, lng同一タスクID列, lng優先度列, lngタスク列, lng工数列, lng担当者列 As Long
Dim lng指定開始日列, lng指定終了日列, lng予定開始日列, lng予定終了日列 As Long

Dim lng最終行 As Long
Dim lng最終列 As Long

Dim rngタスク一覧 As Range

Dim obj担当者 As Object

' ---------------------------------------------------------------------------------------------------------------------
' スケジュール算出
' ---------------------------------------------------------------------------------------------------------------------

Sub スケジュール算出()

    var全体開始日 = Range(txt全体開始日アドレス)

    lng最終行 = 最終行取得(ActiveSheet)
    lng最終列 = 最終列取得(ActiveSheet)

    With ActiveSheet
        Set rngタスク一覧 = .Range(.Cells(lng開始行, 1), .Cells(lng最終行, lng最終列))
    End With

    Call 優先度順に並び替え

    ' -----------------------------------------------------------------------------------------------------------------
    ' 休日シートの読み込み
    ' -----------------------------------------------------------------------------------------------------------------
    '
    Dim obj休日シート As Worksheet: Set obj休日シート = ActiveWorkbook.Sheets(cnst休日シート名)
    Dim var休日リスト As Variant

    With obj休日シート
    
        var休日リスト = .Range(.Cells(2, 1), .Cells(最終行取得(obj休日シート), 1))
        
        ReDim txt休日リスト(LBound(var休日リスト, 1) To UBound(var休日リスト, 1))
        
        Dim i As Long
        For i = LBound(var休日リスト) To UBound(var休日リスト)
        
            txt休日リスト(i) = var休日リスト(i, 1)
        Next
        
    End With

    ' -----------------------------------------------------------------------------------------------------------------
    ' 担当者シートの読み込み
    ' -----------------------------------------------------------------------------------------------------------------
    '
    Dim obj担当者シート As Worksheet: Set obj担当者シート = ActiveWorkbook.Sheets(cnst担当者シート名)
    Dim var担当者リスト As Variant

    With obj担当者シート
    
        var担当者リスト = .Range(.Cells(2, 1), _
            .Cells(最終行取得(obj担当者シート), 最終列取得(obj担当者シート)))
    
        Set obj担当者 = CreateObject("Scripting.Dictionary")
    
        Dim j As Long
        For j = LBound(var担当者リスト) To UBound(var担当者リスト)
                    
            Dim var担当者休日リスト As Variant: var担当者休日リスト = txt休日リスト
            
            If var担当者リスト(j, 3) <> "" Then
            
                Dim k As Long
                Dim tmp担当者休日リスト As Variant: tmp担当者休日リスト = Split(var担当者リスト(j, 3), ",")
                
                ReDim Preserve var担当者休日リスト(UBound(txt休日リスト) + UBound(tmp担当者休日リスト))
                
                For k = LBound(tmp担当者休日リスト) To UBound(tmp担当者休日リスト)
                
                    var担当者休日リスト(UBound(txt休日リスト) + k) = tmp担当者休日リスト(k)
                
                Next
                
            End If
            
            Dim var担当者詳細リスト(1 To 4) As Variant
            var担当者詳細リスト(idx処理中日付) = var全体開始日
            var担当者詳細リスト(idx工数) = 0 ' 処理中の工数（初期値0を設定）
            var担当者詳細リスト(idx1日あたり工数) = var担当者リスト(j, 2) ' 1日あたりの工数
            var担当者詳細リスト(idx休日リスト) = var担当者休日リスト ' 休日
        
            obj担当者.Add var担当者リスト(j, 1), var担当者詳細リスト
        
        Next
    
    End With
    

    ' -----------------------------------------------------------------------------------------------------------------
    ' 予定開始終了日設定
    ' -----------------------------------------------------------------------------------------------------------------
    '
    Call 予定開始終了日設定

End Sub

' ---------------------------------------------------------------------------------------------------------------------
' 優先度準に並び替え
' ---------------------------------------------------------------------------------------------------------------------

Function 優先度順に並び替え()

    rngタスク一覧.Select
    ActiveWorkbook.Worksheets("タスク").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("タスク").Sort.SortFields.Add Key:=Range("D4:D20"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("タスク").Sort.SortFields.Add Key:=Range("G4:G20"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("タスク").Sort.SortFields.Add Key:=Range("H4:H20"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    ActiveWorkbook.Worksheets("タスク").Sort.SortFields.Add Key:=Range("I4:I20"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("タスク").Sort
        .SetRange rngタスク一覧
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

End Function


' ---------------------------------------------------------------------------------------------------------------------
' タスクの一覧をvariantで取得
' ---------------------------------------------------------------------------------------------------------------------

Function タスク一覧取得() As Variant

    Dim varタスク一覧 As Variant

    With ActiveSheet
        varタスク一覧 = .Range(.Cells(lng開始行, 1), .Cells(lng最終行, lng最終列))
    End With

    Dim i As Long
    
    For i = LBound(varタスク一覧, 2) To UBound(varタスク一覧, 2)
    
        Dim txtセルの値 As String: txtセルの値 = varタスク一覧(1, i)
        
        Select Case txtセルの値
            Case "ID"
                lngID列 = i
            Case "先行タスクID"
                lng先行タスクID列 = i
            Case "同一タスクID"
                lng同一タスクID列 = i
            Case "優先度"
                lng優先度列 = i
            Case "タスク"
                lngタスク列 = i
            Case "工数"
                lng工数列 = i
            Case "担当者"
                lng担当者列 = i
            Case "指定開始日"
                lng指定開始日列 = i
            Case "指定終了日"
                lng指定終了日列 = i
            Case "予定開始日"
                lng予定開始日列 = i
            Case "予定終了日"
                lng予定終了日列 = i
        End Select
    Next

    タスク一覧取得 = varタスク一覧

End Function


' ---------------------------------------------------------------------------------------------------------------------
' 予定開始終了日を設定する
' ---------------------------------------------------------------------------------------------------------------------

Sub 予定開始終了日設定()

    ' Dim var日付記録(1 To 2) As Variant
    ' var日付記録(1) = var全体開始日
    ' var日付記録(2) = 0

    Dim varタスク一覧 As Variant: varタスク一覧 = タスク一覧取得
    
    Dim i As Long
    For i = LBound(varタスク一覧) + 1 To UBound(varタスク一覧)
    
        ' 処理中のタスク情報の取得
        Dim lng工数 As Long: lng工数 = varタスク一覧(i, lng工数列)
        Dim txt担当者 As String: txt担当者 = varタスク一覧(i, lng担当者列)

        If obj担当者.Exists(txt担当者) Then

            Dim var担当者情報 As Variant: var担当者情報 = obj担当者.Item(txt担当者)
            Dim lng1日あたりの工数 As Long: lng1日あたりの工数 = var担当者情報(idx1日あたり工数)

            ' 開始日記録
            ActiveSheet.Cells(i + lng開始行 - 1, lng予定開始日列) = var担当者情報(idx処理中日付)
            
            Do While (lng工数 > 0)
    
                Debug.Print (var担当者情報(idx処理中日付) & " " & var担当者情報(idx工数) & " " & lng工数)
    
                ' 対象日の残工数と
                If (lng工数 + var担当者情報(idx工数)) >= lng1日あたりの工数 Then
                
                    ' 稼働日ぴったりの場合のみ終了日をプロットする（終了日算出の中でプロットできないため）
                    If (lng工数 + var担当者情報(idx工数)) = lng1日あたりの工数 Then
                        ActiveSheet.Cells(i + lng開始行 - 1, lng予定終了日列) = var担当者情報(idx処理中日付)
                    End If
                
                    lng工数 = lng工数 - (lng1日あたりの工数 - var担当者情報(idx工数))
                    var担当者情報(idx処理中日付) = 日付を進める(var担当者情報(idx処理中日付), var担当者情報(idx休日リスト))
                    var担当者情報(idx工数) = 0
                    
                Else
                    var担当者情報(idx工数) = var担当者情報(idx工数) + lng工数
                    lng工数 = 0
                    
                    ' 終了日記録
                    ActiveSheet.Cells(i + lng開始行 - 1, lng予定終了日列) = var担当者情報(idx処理中日付)
                    
                End If
            Loop
        
            obj担当者.Item(txt担当者) = var担当者情報
        
        End If
    Next

    Dim obj開始表 As Object
    Set obj開始表 = CreateObject("Scripting.Dictionary")

End Sub

' ---------------------------------------------------------------------------------------------------------------------
' 予定開始終了日を設定する
' ---------------------------------------------------------------------------------------------------------------------

Function 日付を進める(ByVal prm日付 As Variant, ByVal prm休日リスト As Variant)

    Dim var進めた後の日付 As Variant: var進めた後の日付 = prm日付 + 1
    
    Do While True
    
        ' 月曜日から金曜日の場合
        If Weekday(var進めた後の日付) <= 1 Or 7 <= Weekday(var進めた後の日付) Then
    
            var進めた後の日付 = var進めた後の日付 + 1
            
        ElseIf 配列に存在するかチェック(var進めた後の日付, prm休日リスト) Then
        
            var進めた後の日付 = var進めた後の日付 + 1
            
        Else
    
            日付を進める = var進めた後の日付
            Exit Function
        End If
    Loop
    
End Function


Function 配列に存在するかチェック(ByVal prm対象文字列 As Variant, ByVal prm日付配列 As Variant) As Boolean

    Dim i As Long
    For i = LBound(prm日付配列) To UBound(prm日付配列)
    
        If CDate(prm対象文字列) = CDate(prm日付配列(i)) Then
        
            配列に存在するかチェック = True
            Exit Function
        
        End If
    Next
    配列に存在するかチェック = False

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


Function 最終行取得(ws対象シート As Worksheet) As Long

    最終行取得 = ws対象シート.UsedRange.Find("*", , xlFormulas, , xlByRows, xlPrevious).Row

End Function

Function 最終列取得(ws対象シート As Worksheet) As Long

    最終列取得 = ws対象シート.UsedRange.Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column

End Function

2017-07-25

マクロ

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

2010-04-01

FileOperationUtil

Attribute VB_Name = "FileOperationUtil"
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

' *********************************************************************************************************************
' * 機能　：フォルダが存在しなかったら作成する
' *********************************************************************************************************************
'
Function mkdirIFNotExist(txtフォルダ名 As String)

    If Dir(txtフォルダ名, vbDirectory) = "" Then
        mkdir txtフォルダ名
    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