【Excel VBA 再利用コード集】シフト表に氏名の「略称」を書き込む

Dom_CreateCalendar
└─ AddShukujisuToTanmuWs（担務表ヘッダに祝日情報を反映して書き戻す）
　 ├─ GetShukujitsuTbl（祝日シートを配列で取得）
　 │　└─ Util_GetArray
　 │　　 ├─ GetUsedRangeArray（使用範囲を配列で取得）
　 │　　 └─ DebugPrintArraySize（配列サイズをデバッグ出力）
　 │
　 └─ AddShukujitsuToTanmuHeaderTbl（担務表ヘッダ配列へ祝日名を反映）

Dom_CreateTanmuWs
└ CreateTanmuWs（曜日条件に合うセルのみ担当者を割当＋略称を表示）
   ├ Util_GetArray
   │  ├ GetUsedRangeArray（使用範囲を配列で取得）
   │  └ DebugPrintArraySize（配列サイズをデバッグ出力）
   ├ Dom_CreateDic
   │  ├ CreateShiftWariateDic（シフト→可スタッフ辞書 ※キー=略称／シフト割当表B列）
   │  └ CreateYoubiJoukenDic（シフト→曜日条件辞書）
   ├ GetYoubiKeyFromTanmuHeader（祝日優先で「祝」/ 曜日を返す　※同一モジュール内）
   └ Util_ShuffleElements
      └ ShuffleArrayByFisherYates（候補者シャッフル）

Option Explicit


Public Sub AddShukujisuToTanmuWs()

    ' Description
    '   担務表ヘッダ配列に祝日情報を反映し、シートへ書き戻す。
    '
    ' Arguments
    '   (none)
    '
    ' Returns
    '   (none)


    ' 担務表シート取得
    Dim tanmu_ws As Worksheet
    Set tanmu_ws = ThisWorkbook.Worksheets("担務表")

    ' 担務表ヘッダー配列取得
    Dim tanmu_header_tbl As Variant
    tanmu_header_tbl = tanmu_ws.Range("A1:AL4").Value
    
    ' 祝日配列取得
    Dim shukujitsu_tbl As Variant
    shukujitsu_tbl = GetShukujitsuTbl()

    ' ガード（空配列など）
    If IsEmpty(tanmu_header_tbl) Or (Not IsArray(tanmu_header_tbl)) Then
        MsgBox "tanmu_header_tbl が取得できません。", vbExclamation
        Exit Sub
    End If

    If IsEmpty(shukujitsu_tbl) Or (Not IsArray(shukujitsu_tbl)) Then
        MsgBox "shukujitsu_tbl が取得できません。", vbExclamation
        Exit Sub
    End If

    ' 祝日反映（配列更新）
    Call AddShukujitsuToTanmuHeaderTbl(tanmu_header_tbl, shukujitsu_tbl)

    ' シートへ書き戻し
    tanmu_ws.Range( _
        tanmu_ws.Cells(1, 1), _
        tanmu_ws.Cells( _
            UBound(tanmu_header_tbl, 1), _
            UBound(tanmu_header_tbl, 2) _
        ) _
    ).Value2 = tanmu_header_tbl

End Sub

Private Function GetShukujitsuTbl() As Variant

    ' Description
    '   「祝日」シートの「A1:B最終行」までを、配列として取得する

    ' 祝日シートを取得
    Dim ws As Worksheet            ' 祝日シート
    Set ws = ThisWorkbook.Worksheets("祝日")

    ' 対象ワークシートの使用範囲を配列で取得(Util_GetArray 呼び出し)
    Dim shukujitsu_tbl As Variant     ' 祝日を格納する配列
    shukujitsu_tbl = GetUsedRangeArray(ws)
    Call DebugPrintArraySize(shukujitsu_tbl, "祝日シート配列")

    ' Return: 配列を返却
    GetShukujitsuTbl = shukujitsu_tbl

End Function

Private Sub AddShukujitsuToTanmuHeaderTbl( _
    ByRef tanmu_header_tbl As Variant, _
    ByVal shukujitsu_tbl As Variant _
)

    ' Description
    '   祝日配列（shukujitsu_tbl）に一致する日付が担務表ヘッダ配列（tanmu_header_tbl）の
    '   カレンダー範囲に存在した場合、該当列の祝日行セルを更新する。
    '
    ' Arguments
    '   tanmu_header_tbl : 担務表ヘッダを格納した2次元配列（更新対象）
    '   shukujitsu_tbl   : 祝日シートを格納した2次元配列（参照のみ）
    '
    ' Returns
    '   (none)
    
    
    ' ガード（空配列など）
    If IsEmpty(tanmu_header_tbl) Or (Not IsArray(tanmu_header_tbl)) Then
        MsgBox "tanmu_header_tbl が Empty / 配列ではありません。", vbExclamation
        Exit Sub
    End If

    If IsEmpty(shukujitsu_tbl) Or (Not IsArray(shukujitsu_tbl)) Then
        MsgBox "shukujitsu_tbl が Empty / 配列ではありません。", vbExclamation
        Exit Sub
    End If


    ' 固定仕様（担務表ヘッダ）
    Const DATE_ROW As Long = 1                ' 日付行（担務表ヘッダ内）
    Const SHUKUJITSU_ROW As Long = 3          ' 祝日書き込み行
    Const CALENDAR_START_COL As Long = 2      ' B
    Const CALENDAR_END_COL As Long = 32       ' AF

    ' 祝日配列の最終行を取得
    Dim shukujitsu_last_row As Long
    shukujitsu_last_row = UBound(shukujitsu_tbl, 1)

    ' 祝日配列を走査（2行目～最終行：1行目はヘッダ）
    Dim row As Long
    For row = 2 To shukujitsu_last_row
    
        ' 祝日日付を取得（空行・日付以外はスキップ）
        If Not IsDate(shukujitsu_tbl(row, 1)) Then GoTo ContinueShukujitsuRow
        Dim shukujitsu_date As Date
        shukujitsu_date = shukujitsu_tbl(row, 1)
    
        ' 祝日名を取得（空行はスキップ）
        Dim shukujitsu_name As String
        shukujitsu_name = CStr(shukujitsu_tbl(row, 2))
        If Len(shukujitsu_name) = 0 Then GoTo ContinueShukujitsuRow
    
        ' 担務表ヘッダの日付行を走査
        Dim col As Long
        For col = CALENDAR_START_COL To CALENDAR_END_COL
    
            ' 日付が一致した列に祝日名をセット
            If tanmu_header_tbl(DATE_ROW, col) = shukujitsu_date Then
                tanmu_header_tbl(SHUKUJITSU_ROW, col) = _
                    Left(shukujitsu_name, 2)
                Exit For
            End If
    
        Next col
    
ContinueShukujitsuRow:
    Next row

End Sub

Option Explicit


Public Function CreateShiftWariateDic() As Scripting.Dictionary

    ' Description
    '   シフト割当表シートを参照し、シフト名→可（〇）スタッフ辞書を作成して返す。
    '   外側辞書：Key=シフト名、value=内側辞書（可スタッフ辞書）
    '
    ' Arguments
    '   (None)
    '
    ' Returns
    '   Dictionary
    '     key   : shift_name (String)
    '     value : Dictionary
    '               key   : staff_ryakusho (String)
    '               value : True (Boolean)
    '
    ' References
    '   Microsoft Scripting Runtime


    ' シートの取得
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("シフト割当表")

    ' シートの対象範囲を配列として取得
    Dim staff_shift_kahi_tbl As Variant
    staff_shift_kahi_tbl = GetUsedRangeArray(ws)
    Call DebugPrintArraySize(staff_shift_kahi_tbl, "シフト割当表配列")

    ' 固定仕様（シフト割当表）
    Const STAFF_RYAKUSHO_COL  As Long = 2   ' 略称列（B列）
    Const SHIFT_START_COL     As Long = 3   ' シフト開始列（C列）
    Const HEADER_ROW          As Long = 1   ' ヘッダ行
    Const DATA_START_ROW      As Long = 2   ' データ開始行

    ' ガード（空配列）
    If IsEmpty(staff_shift_kahi_tbl) Then
        Set CreateShiftWariateDic = Nothing
        Exit Function
    End If

    ' 外側辞書：シフト名 → 可スタッフ辞書 の対応を保持する辞書
    Dim staff_shift_kahi_dic As Scripting.Dictionary
    Set staff_shift_kahi_dic = New Scripting.Dictionary

    ' 配列を列方向に走査
    Dim shift_col As Long
    For shift_col = SHIFT_START_COL To UBound(staff_shift_kahi_tbl, 2)

        ' シフト名を取得（空欄はスキップ）
        Dim shift_name As String
        shift_name = Trim$(CStr(staff_shift_kahi_tbl(HEADER_ROW, shift_col)))
        If Len(shift_name) = 0 Then GoTo NextShiftCol

        ' 外側辞書に「シフト名」が未登録の場合
        If Not staff_shift_kahi_dic.Exists(shift_name) Then

            ' 内側辞書（可スタッフ辞書）を新規作成
            Dim assignable_staff_dic As Scripting.Dictionary
            Set assignable_staff_dic = New Scripting.Dictionary

            ' 「シフト名」をキー、「可スタッフ辞書」をバリューとして外側辞書に登録
            staff_shift_kahi_dic.Add shift_name, assignable_staff_dic

        End If

        ' 内側辞書にスタッフを登録
        Dim staff_row As Long
        For staff_row = DATA_START_ROW To UBound(staff_shift_kahi_tbl, 1)

            ' 略称を取得（空欄は対象外）
            Dim staff_ryakusho As String
            staff_ryakusho = Trim$(CStr(staff_shift_kahi_tbl(staff_row, STAFF_RYAKUSHO_COL)))
            If Len(staff_ryakusho) = 0 Then GoTo NextStaffRow

            ' クロスポイントの値を取得（○がなければ対象外）
            Dim cell_val As String
            cell_val = Trim$(CStr(staff_shift_kahi_tbl(staff_row, shift_col)))
            If InStr(1, cell_val, "○", vbTextCompare) = 0 Then GoTo NextStaffRow

            ' 内側辞書に未登録の場合、略称を追加
            If Not staff_shift_kahi_dic(shift_name).Exists(staff_ryakusho) Then
                staff_shift_kahi_dic(shift_name).Add staff_ryakusho, True
            End If

NextStaffRow:
        Next staff_row

NextShiftCol:
    Next shift_col

    ' シフト割当表辞書を返す
    Set CreateShiftWariateDic = staff_shift_kahi_dic

End Function


Public Function CreateYoubiJoukenDic() As Scripting.Dictionary

    ' Description
    '   シフト曜日条件表シートを参照し、シフト名→曜日条件辞書を作成して返す。
    '   外側辞書：Key=シフト名、value=内側辞書（曜日条件辞書）
    '
    ' Arguments
    '   (None)
    '
    ' Returns
    '   Dictionary
    '     key   : shift_name (String)
    '     value : Dictionary
    '               key   : youbi_key (String)  "日","月","火","水","木","金","土","祝"
    '               value : True (Boolean)
    '
    ' References
    '   Microsoft Scripting Runtime


    ' シートの取得
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets("シフト曜日条件表")

    ' シートの対象範囲を配列として取得
    Dim youbi_jouken_tbl As Variant
    youbi_jouken_tbl = GetUsedRangeArray(ws)
    Call DebugPrintArraySize(youbi_jouken_tbl, "シフト曜日条件表配列")

    ' ガード（空配列）
    If IsEmpty(youbi_jouken_tbl) Then
        Set CreateYoubiJoukenDic = Nothing
        Exit Function
    End If


    ' 固定仕様（シフト曜日条件表）
    Const SHIFT_NAME_COL   As Long = 1   ' シフト名列
    Const YOU_BI_START_COL As Long = 2   ' 曜日開始列
    Const HEADER_ROW       As Long = 1   ' ヘッダ行
    Const DATA_START_ROW   As Long = 2   ' データ開始行（シフト行）

    ' 外側辞書：シフト名 → 曜日条件辞書 の対応を保持する辞書
    Dim youbi_jouken_dic As Scripting.Dictionary
    Set youbi_jouken_dic = New Scripting.Dictionary


    ' 行方向（シフト）を走査し、内側辞書を作成
    '--------------------------------------------------------------------------
    Dim shift_row As Long
    For shift_row = DATA_START_ROW To UBound(youbi_jouken_tbl, 1)

        ' シフト名を取得（空欄はスキップ）
        Dim shift_name As String
        shift_name = Trim$(CStr(youbi_jouken_tbl(shift_row, SHIFT_NAME_COL)))
        If Len(shift_name) = 0 Then GoTo NextShiftRow

        ' 内側辞書（曜日条件辞書）を新規作成
        Dim youbi_dic As Scripting.Dictionary
        Set youbi_dic = New Scripting.Dictionary

        ' 列方向（曜日）を走査し、○の曜日のみ内側辞書に登録
        '----------------------------------------------------------------------
        Dim youbi_col As Long
        For youbi_col = YOU_BI_START_COL To UBound(youbi_jouken_tbl, 2)

            ' 曜日キーを取得（空欄はスキップ）
            Dim header_val As String
            header_val = Trim$(CStr(youbi_jouken_tbl(HEADER_ROW, youbi_col)))
            If Len(header_val) = 0 Then GoTo NextYoubiCol

            Dim youbi_key As String
            If header_val = "祝日" Then
                youbi_key = "祝"
            Else
                youbi_key = header_val
            End If

            ' クロスポイントの値を取得（○/〇がなければ対象外）
            Dim cell_val As String
            cell_val = Trim$(CStr(youbi_jouken_tbl(shift_row, youbi_col)))

            If InStr(1, cell_val, "○", vbTextCompare) = 0 _
                And InStr(1, cell_val, "〇", vbTextCompare) = 0 Then _
                GoTo NextYoubiCol

            ' 内側辞書に未登録の場合、曜日キーを追加
            If Not youbi_dic.Exists(youbi_key) Then
                youbi_dic.Add youbi_key, True
            End If

NextYoubiCol:
        Next youbi_col

        ' 外側辞書に登録（内側辞書）
        youbi_jouken_dic.Add shift_name, youbi_dic

NextShiftRow:
    Next shift_row


    ' Return
    Set CreateYoubiJoukenDic = youbi_jouken_dic

End Function


' 辞書の中身をデバッグ表示するプロシージャ群
'------------------------------------------------------------------------------
Public Sub DebugPrintShiftWariateDic()

    ' シフト→可スタッフ辞書を作成（辞書が取得できなかった場合は終了）
    Dim staff_shift_kahi_dic As Scripting.Dictionary
    Set staff_shift_kahi_dic = CreateShiftWariateDic()
    If staff_shift_kahi_dic Is Nothing Then Exit Sub

    ' 辞書の中身を確認（Debug.Print）
    Call DebugPrintNestedDic(staff_shift_kahi_dic, "シフト→可スタッフ辞書")

End Sub

Public Sub DebugPrintYoubiJoukenDic()

    ' シフト→曜日条件辞書を作成（辞書が取得できなかった場合は終了）
    Dim youbi_jouken_dic As Scripting.Dictionary
    Set youbi_jouken_dic = CreateYoubiJoukenDic()
    If youbi_jouken_dic Is Nothing Then Exit Sub

    ' 辞書の中身を確認（Debug.Print）
    Call DebugPrintNestedDic(youbi_jouken_dic, "シフト→曜日条件辞書")

End Sub


' ネストした辞書の中身を表示する汎用プロシージャ
'------------------------------------------------------------------------------
Public Sub DebugPrintNestedDic(ByVal outer_dic As Scripting.Dictionary, ByVal label As String)

    ' Description
    '   外側辞書の value が Dictionary である 2 段辞書を Debug.Print で出力する。
    '
    ' Arguments
    '   outer_dic : 外側辞書（value は Scripting.Dictionary を想定）
    '   label     : デバッグ出力用の識別子
    '
    ' Returns
    '   (none)


    ' ガード
    If outer_dic Is Nothing Then
        Debug.Print label & " : outer_dic is Nothing"
        Exit Sub
    End If


    ' 辞書の中身を確認（Debug.Print）
    '--------------------------------------------------------------------------
    Debug.Print label & " : count=" & outer_dic.Count

    Dim outer_key As Variant
    For Each outer_key In outer_dic.Keys

        Debug.Print outer_key

        ' 内側辞書を取得（辞書でなければスキップ）
        Dim inner_dic As Scripting.Dictionary
        On Error Resume Next
        Set inner_dic = outer_dic(outer_key)
        On Error GoTo 0
        If inner_dic Is Nothing Then GoTo NextOuterKey

        ' 内側辞書のキーを出力
        Dim inner_key As Variant
        For Each inner_key In inner_dic.Keys
            Debug.Print "  "; inner_key
        Next inner_key

NextOuterKey:
    Next outer_key

End Sub

Option Explicit


Public Sub CreateTanmuWs()

    ' Description
    '   シフト割当表から作成した「シフト名→可スタッフ辞書」を参照し、
    '   担務表の各日付×各シフトの未割当セルへ担当者名を割り当てる。
    '   曜日条件表（○）に一致するセルのみ割り当てる。
    '   候補者はシャッフルし、先頭要素を採用する（追加制約は入れない）。
    '
    ' Arguments
    '   (None)
    '
    ' Returns
    '   なし


    ' 固定仕様（担務表）
    Const TANMU_SHEET_NAME       As String = "担務表"
    Const TANMU_SHIFT_NAME_COL   As Long = 1   ' A列
    Const TANMU_DATE_ROW         As Long = 1   ' 1行目
    Const TANMU_DATA_START_ROW   As Long = 4   ' 4行目
    Const TANMU_DATE_START_COL   As Long = 9   ' I列


    ' 担務表・シフト割当辞書の取得
    '--------------------------------------------------------------------------
    ' 担務表シートの取得
    Dim ws As Worksheet
    Set ws = ThisWorkbook.Worksheets(TANMU_SHEET_NAME)
    
    ' 担務表配列の取得
    Dim tanmu_tbl As Variant
    tanmu_tbl = GetUsedRangeArray(ws)
    Call DebugPrintArraySize(tanmu_tbl, "担務表配列")
    If IsEmpty(tanmu_tbl) Then Exit Sub
    
    ' シフト割当辞書の取得
    Dim staff_shift_kahi_dic As Scripting.Dictionary
    Set staff_shift_kahi_dic = CreateShiftWariateDic()
    If staff_shift_kahi_dic Is Nothing Then Exit Sub

    ' 曜日条件辞書の取得
    Dim youbi_jouken_dic As Scripting.Dictionary
    Set youbi_jouken_dic = CreateYoubiJoukenDic()
    If youbi_jouken_dic Is Nothing Then Exit Sub


    ' 割当処理（日付列×担務行を走査）
    '--------------------------------------------------------------------------
    Dim assign_count As Long
    assign_count = 0
    
    ' 担務表配列の列方向を走査
    Dim date_col As Long
    For date_col = TANMU_DATE_START_COL To UBound(tanmu_tbl, 2)

        ' 日付セルが空の列はスキップ（列の終端対策）
        Dim date_val As String
        date_val = Trim$(CStr(tanmu_tbl(TANMU_DATE_ROW, date_col)))
        If Len(date_val) = 0 Then GoTo NextDateCol

        ' 曜日キーを取得（祝日優先）
        Dim youbi_key As String
        youbi_key = GetYoubiKeyFromTanmuHeader(tanmu_tbl, date_col)
        If Len(youbi_key) = 0 Then GoTo NextDateCol
        
        ' 担務表配列の行方向を走査
        Dim tanmu_row As Long
        For tanmu_row = TANMU_DATA_START_ROW To UBound(tanmu_tbl, 1)

            ' 担務表からシフト名を取得（空欄は対象外）
            Dim shift_name As String
            shift_name = Trim$(CStr(tanmu_tbl(tanmu_row, TANMU_SHIFT_NAME_COL)))
            If Len(shift_name) = 0 Then GoTo NextTanmuRow

            ' 曜日条件（○）に一致しないセルは割当対象外:
            '   現在のシフト名が曜日条件表に定義されていない場合
            If Not youbi_jouken_dic.Exists(shift_name) Then GoTo NextTanmuRow
            
            '   現在の曜日（または祝日）がシフト曜日条件に該当していない場合
            If Not youbi_jouken_dic(shift_name).Exists(youbi_key) Then GoTo NextTanmuRow

            ' 既に値が入っているセルは変更しない
            Dim cell_value As String
            cell_value = Trim$(CStr(tanmu_tbl(tanmu_row, date_col)))
            If Len(cell_value) > 0 Then GoTo NextTanmuRow

            ' シフト割当辞書にシフト名が存在しない場合はスキップ
            If Not staff_shift_kahi_dic.Exists(shift_name) Then GoTo NextTanmuRow
            
            ' 対象シフトに割り当て可能なスタッフ辞書を取得（取得できない場合はスキップ）
            Dim assignable_staff_dic As Scripting.Dictionary
            Set assignable_staff_dic = staff_shift_kahi_dic(shift_name)
            If assignable_staff_dic Is Nothing Then GoTo NextTanmuRow
            
            ' 可スタッフが存在しない場合は割当対象外
            Dim staff_count As Long    ' 割り当て可能なスタッフの人数
            staff_count = assignable_staff_dic.Count
            If staff_count = 0 Then GoTo NextTanmuRow

            ' 可スタッフ辞書のキー（スタッフ名一覧）を配列として取得
            Dim temp_keys As Variant
            temp_keys = assignable_staff_dic.Keys
            
            ' スタッフリスト配列を1始まりで定義
            Dim staff_list() As Variant
            ReDim staff_list(1 To staff_count)
            
            ' 1始まりのスタッフ配列に詰め替え
            Dim idx As Long
            For idx = 1 To staff_count
                staff_list(idx) = temp_keys(idx - 1)
            Next idx

            ' 候補者をシャッフルしたリストを取得
            Dim shuffled_list As Variant
            shuffled_list = ShuffleArrayByFisherYates(staff_list, staff_count)
            
            ' シャッフルしたリストの先頭の候補者を取得
            Dim assign_person As String
            assign_person = Trim$(CStr(shuffled_list(1)))
            
            ' 候補者が0人でなければ
            If Len(assign_person) > 0 Then
                ' 担務表配列に略称を書き込む
                tanmu_tbl(tanmu_row, date_col) = assign_person
                assign_count = assign_count + 1
            End If

NextTanmuRow:
        Next tanmu_row

NextDateCol:
    Next date_col


    ' 担務表シートに書き戻し
    '--------------------------------------------------------------------------
    ws.Range( _
        ws.Cells(1, 1), _
        ws.Cells(UBound(tanmu_tbl, 1), UBound(tanmu_tbl, 2)) _
    ).Value = tanmu_tbl

    Debug.Print "担務表 割当 件数 = " & assign_count

End Sub


Public Function GetYoubiKeyFromTanmuHeader( _
    ByVal tanmu_header_tbl As Variant, _
    ByVal target_col As Long _
) As String

    ' Description
    '   担務表ヘッダ配列の指定列から、曜日条件判定に使用するキー（曜日 or 祝）を返す。
    '   祝日行に値が入っている場合は曜日よりも祝日判定を優先し、「祝」を返す。
    '
    ' Arguments
    '   tanmu_header_tbl : 担務表ヘッダを格納した2次元配列
    '   target_col       : 対象列（担務表ヘッダ配列の列番号）
    '
    ' Returns
    '   String
    '     - 祝日行に値が入っている場合 : "祝"
    '     - それ以外の場合             : 曜日行の文字列（例："月"）


    ' 固定仕様（担務表ヘッダ）
    Const YOUBI_ROW As Long = 2
    Const SHUKUJITSU_ROW As Long = 3

    ' 祝日優先：祝日行に値があれば「祝」
    Dim shukujitsu_val As String
    shukujitsu_val = Trim$(CStr(tanmu_header_tbl(SHUKUJITSU_ROW, target_col)))
    If Len(shukujitsu_val) > 0 Then
        GetYoubiKeyFromTanmuHeader = "祝"
        Exit Function
    End If

    ' 祝日でない場合：曜日行の値を返す
    GetYoubiKeyFromTanmuHeader = _
        Trim$(CStr(tanmu_header_tbl(YOUBI_ROW, target_col)))

End Function

Option Explicit


' 配列操作関連プロシージャ
'------------------------------------------------------------------------------

Sub DebugPrintArraySize(ByVal arr As Variant, ByVal label As String)

    ' Description
    ' 配列の行要素数・列要素数をイミディエイトウィンドウに出力する
    '
    ' Arguments
    ' arr   : 行列構造を持つ配列
    ' label : デバッグ出力用の識別子（シート名など）


    ' 配列が Empty の場合処理を中断する
    If IsEmpty(arr) Then
        Debug.Print label & " : 配列が Empty です"
        Exit Sub
    End If

    ' 配列の行要素数・列要素数を出力
    Debug.Print label & _
                " 行要素数=" & (UBound(arr, 1) - LBound(arr, 1) + 1) & _
                " 列要素数=" & (UBound(arr, 2) - LBound(arr, 2) + 1)

End Sub


Function GetUsedRangeArray(ByVal ws As Worksheet) As Variant
    
    ' Description
    '   指定されたワークシートの使用範囲を判定し、
    '   Cells(1,1) から最終行・最終列までを配列として返す
    '
    ' Arguments
    '   ws  : 対象となるワークシート
    '
    ' Returns
    '   Variant
    '     ・使用範囲が存在する場合：
    '         Cells(1,1) ～ 最終行・最終列 を格納した 2 次元配列
    '     ・シートにデータが存在しない場合：
    '         Empty
    

    ' シートにデータが存在しない場合は Empty を返す
    If ws.Cells.Find("*") Is Nothing Then
        GetUsedRangeArray = Empty
        MsgBox "シートにデータが存在しません。", vbExclamation
        Exit Function
    End If


    ' 最終行・最終列の取得
    Dim last_row As Long
    Dim last_col As Long

    With ws
        last_row = .Cells.Find( _
                        "*", _
                        SearchOrder:=xlByRows, _
                        SearchDirection:=xlPrevious _
                    ).row

        last_col = .Cells.Find( _
                        "*", _
                        SearchOrder:=xlByColumns, _
                        SearchDirection:=xlPrevious _
                    ).Column
    End With


    ' Return：使用範囲を配列として返す
    GetUsedRangeArray = _
        ws.Range( _
            ws.Cells(1, 1), _
            ws.Cells(last_row, last_col) _
        ).Value

End Functionk

Option Explicit


' シャッフル関連プロシージャ
'------------------------------------------------------------------------------
Function ShuffleArrayByFisherYates( _
    ByVal src_arr As Variant, _
    ByVal arr_count As Long _
) As Variant

    ' Description
    '   指定された配列の先頭 arr_count 要素を対象に、
    '   フィッシャー・イェーツ法でランダムに並び替えた
    '   新しい配列を返却する
    '
    '   ・元の配列は変更しない
    '   ・arr_count が 0 または 1 の場合は並び替えを行わない
    '
    ' Arguments
    '   src_arr : 並び替え対象の配列（1始まり想定）
    '   arr_count : 有効要素数（先頭から arr_count 件）
    '
    ' Returns
    '   Variant
    '     - ランダムに並び替えられた配列


    ' ガード
    If arr_count <= 1 Then
        ShuffleArrayByFisherYates = src_arr
        Exit Function
    End If


    ' 作業用配列を初期化（有効要素分のみ）
    Dim work_arr() As Variant   ' 作業用配列
    ReDim work_arr(1 To arr_count)


    ' 元配列からコピー
    Dim i As Long
    For i = 1 To arr_count
        work_arr(i) = src_arr(i)
    Next i


    ' フィッシャー・イェーツシャッフル
    For i = arr_count To 2 Step -1

        Dim j As Long
        j = Int(Rnd * i) + 1

        Dim tmp As Variant
        tmp = work_arr(i)
        work_arr(i) = work_arr(j)
        work_arr(j) = tmp

    Next i


    ' Return
    ShuffleArrayByFisherYates = work_arr

End Function