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

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