Option Explicit'================================================================================'自動割り振り'' ・このコード全体を、対象ブック内の「標準モジュール」1つへ貼り付けて使用します。' ・参照設定は不要です。' ・会社で変更する箇所は、原則としてこの「設定」部分と座席一覧だけです。'================================================================================'============================== 設定：シート名 ==============================Private Const SHIFT_SHEET_NAME As String = "シフト表"Private Const TL_LIST_SHEET_NAME As String = "TL一覧"Private Const LOG_SHEET_NAME As String = "TL割当ログ"'============================== 設定：シフト表 =============================='氏名が縦、日付が横に並ぶ表を想定Private Const SHIFT_DATE_ROW As Long = 1          '日付が入っている行Private Const SHIFT_NAME_COL As Long = 1          '氏名が入っている列Private Const SHIFT_FIRST_NAME_ROW As Long = 2    '氏名の開始行Private Const SHIFT_FIRST_DATE_COL As Long = 2    '日付の開始列'日付見出しが実日付で、複数月が同じシートにある場合だけ指定'0の場合は年・月を限定せず、見出しの日だけで判定Private Const TARGET_YEAR As Long = 0Private Const TARGET_MONTH As Long = 0'============================== 設定：TL一覧 ================================Private Const TL_LIST_NAME_COL As Long = 1        'TL氏名が入っている列Private Const TL_LIST_FIRST_ROW As Long = 2       'TL氏名の開始行'============================== 設定：座席 =================================='未割り当てのTL固定席に入っている文字Private Const TL_MARKER As String = "TL"'空いているメンバー席として扱う文字'完全な空白も空席として扱うPrivate Const MEMBER_EMPTY_MARKER As String = "空席"'============================== 設定：在宅色 ================================'会社の在宅セルと同じRGB値へ変更Private Const REMOTE_COLOR_R As Long = 0Private Const REMOTE_COLOR_G As Long = 112Private Const REMOTE_COLOR_B As Long = 192'True：条件付き書式を含む、画面上で見えている色を使う'False：セルへ直接設定された塗りつぶし色を使うPrivate Const USE_DISPLAY_FORMAT As Boolean = True'============================== 設定：動作 =================================='優先席を持たないTLと空席の組み合わせをランダム化Private Const RANDOMIZE_UNPREFERRED_ASSIGNMENTS As Boolean = True'実行前に確認メッセージを表示Private Const SHOW_CONFIRMATION As Boolean = True'ログ出力用Private mLogWs As WorksheetPrivate mLogNextRow As Long'================================================================================' メインマクロ'================================================================================Public Sub TL座席を一括割り振る()    Dim wb As Workbook    Dim shiftWs As Worksheet    Dim tlListWs As Worksheet    Dim dayWs As Worksheet    Dim tlSeats As Collection    Dim memberSeats As Collection    Dim tlNames As Object    Dim shiftNameRows As Object    Dim shiftDateColumns As Object    Dim daySheets As Object    Dim workingTLs As Object    Dim lastWorkDay As Object    Dim lastSeat As Object    Dim lastSeatDay As Object    Dim previousCalculation As XlCalculation    Dim previousScreenUpdating As Boolean    Dim previousEnableEvents As Boolean    Dim previousDisplayAlerts As Boolean    Dim appStateCaptured As Boolean    Dim settingsMessage As String    Dim answer As VbMsgBoxResult    Dim dayNumber As Long    Dim personKey As Variant    Dim processedSheetCount As Long    Dim skippedSheetCount As Long    Dim assignedCount As Long    Dim unassignedCount As Long    Dim errorNumber As Long    Dim errorDescription As String    Dim resultMessage As String    Set wb = ThisWorkbook    Set tlSeats = GetTLSeatAddresses()    Set memberSeats = GetMemberSeatAddresses()    If Not ValidateSettings(wb, tlSeats, memberSeats, settingsMessage) Then        MsgBox "設定を確認してください。" & vbCrLf & vbCrLf & settingsMessage, _               vbExclamation, "TL座席割り振り"        Exit Sub    End If    If SHOW_CONFIRMATION Then        answer = MsgBox( _            "日付シートのTL席をシフトに基づいて割り振ります。" & vbCrLf & _            "TL固定席がすべて「" & TL_MARKER & "」のシートだけが処理対象です。" & vbCrLf & vbCrLf & _            "実行しますか？", _            vbQuestion + vbYesNo + vbDefaultButton2, _            "TL座席割り振り")        If answer <> vbYes Then Exit Sub    End If    On Error GoTo FatalError    previousCalculation = Application.Calculation    previousScreenUpdating = Application.ScreenUpdating    previousEnableEvents = Application.EnableEvents    previousDisplayAlerts = Application.DisplayAlerts    appStateCaptured = True    Application.ScreenUpdating = False    Application.EnableEvents = False    Application.DisplayAlerts = False    Application.Calculation = xlCalculationManual    Application.StatusBar = "TL座席割り振りの準備中..."    If RANDOMIZE_UNPREFERRED_ASSIGNMENTS Then Randomize    Set mLogWs = PrepareLogSheet(wb)    mLogNextRow = 2    Set shiftWs = wb.Worksheets(SHIFT_SHEET_NAME)    Set tlListWs = wb.Worksheets(TL_LIST_SHEET_NAME)    Set tlNames = BuildTLDictionary(tlListWs)    Set shiftNameRows = BuildShiftNameRowDictionary(shiftWs)    Set shiftDateColumns = BuildShiftDateColumnDictionary(shiftWs)    Set daySheets = BuildDaySheetDictionary(wb)    If tlNames.Count = 0 Then        Err.Raise vbObjectError + 1001, "TL座席割り振り", _                  "「" & TL_LIST_SHEET_NAME & "」シートからTL氏名を取得できませんでした。"    End If    If shiftDateColumns.Count = 0 Then        Err.Raise vbObjectError + 1002, "TL座席割り振り", _                  "「" & SHIFT_SHEET_NAME & "」シートから日付見出しを取得できませんでした。"    End If    If daySheets.Count = 0 Then        Err.Raise vbObjectError + 1003, "TL座席割り振り", _                  "1～31の日付を表すシートが見つかりませんでした。"    End If    For Each personKey In tlNames.Keys        If Not shiftNameRows.Exists(CStr(personKey)) Then            WriteLog 0, "警告", CStr(tlNames(personKey)), "", _                     "TL一覧にはありますが、シフト表の氏名列に見つかりません。"        End If    Next personKey    If memberSeats.Count = 0 Then        WriteLog 0, "注意", "", "", _                 "メンバー席が未設定です。TL固定席数を超えたTLは未割り当てになります。"    End If    Set lastWorkDay = NewTextDictionary()    Set lastSeat = NewTextDictionary()    Set lastSeatDay = NewTextDictionary()    For dayNumber = 1 To 31        Application.StatusBar = dayNumber & "日を処理中..."        Set workingTLs = NewTextDictionary()        If shiftDateColumns.Exists(CStr(dayNumber)) Then            Set workingTLs = BuildWorkingTLDictionary( _                                shiftWs, _                                CLng(shiftDateColumns(CStr(dayNumber))), _                                tlNames, _                                shiftNameRows)        End If        If daySheets.Exists(CStr(dayNumber)) Then            Set dayWs = wb.Worksheets(CStr(daySheets(CStr(dayNumber))))            If Not shiftDateColumns.Exists(CStr(dayNumber)) Then                skippedSheetCount = skippedSheetCount + 1                WriteLog dayNumber, "スキップ", "", "", _                         "シフト表に対応する日付列が見つかりません。"            ElseIf dayWs.ProtectContents Then                skippedSheetCount = skippedSheetCount + 1                ReadExistingAssignments dayWs, dayNumber, workingTLs, _                                        tlSeats, memberSeats, lastSeat, lastSeatDay                WriteLog dayNumber, "スキップ", "", "", _                         "シートが保護されているため書き込めません。既存の割り当てだけ履歴として読み込みました。"            ElseIf Not AreAllTLSeatsMarkers(dayWs, tlSeats) Then                skippedSheetCount = skippedSheetCount + 1                ReadExistingAssignments dayWs, dayNumber, workingTLs, _                                        tlSeats, memberSeats, lastSeat, lastSeatDay                WriteLog dayNumber, "スキップ", "", "", _                         "TL固定席の全セルが「" & TL_MARKER & "」ではないため、既存割り当て済みとして処理を飛ばしました。"            ElseIf HasAnyTLInMemberSeats(dayWs, tlNames, memberSeats) Then                skippedSheetCount = skippedSheetCount + 1                ReadExistingAssignments dayWs, dayNumber, workingTLs, _                                        tlSeats, memberSeats, lastSeat, lastSeatDay                WriteLog dayNumber, "スキップ", "", "", _                         "メンバー席にTL名がすでに入っているため、重複防止のため処理を飛ばしました。"            Else                processedSheetCount = processedSheetCount + 1                AssignTLsForDay dayWs, dayNumber, workingTLs, _                                tlSeats, memberSeats, _                                lastWorkDay, lastSeat, lastSeatDay, _                                assignedCount, unassignedCount            End If        End If        'その日の出勤実績を更新        '日付シートがない日も、翌日の連続出勤判定には反映する        For Each personKey In workingTLs.Keys            PutDictionaryValue lastWorkDay, CStr(personKey), dayNumber        Next personKey    Next dayNumber    FinalizeLogSheet    resultMessage = _        "TL座席の割り振りが完了しました。" & vbCrLf & vbCrLf & _        "処理した日付シート：" & processedSheetCount & vbCrLf & _        "スキップした日付シート：" & skippedSheetCount & vbCrLf & _        "割り当て人数：" & assignedCount & vbCrLf & _        "未割り当て人数：" & unassignedCount & vbCrLf & vbCrLf & _        "詳細は「" & LOG_SHEET_NAME & "」シートを確認してください。"    MsgBox resultMessage, vbInformation, "TL座席割り振り"SafeExit:    On Error Resume Next    If appStateCaptured Then        Application.Calculation = previousCalculation        Application.ScreenUpdating = previousScreenUpdating        Application.EnableEvents = previousEnableEvents        Application.DisplayAlerts = previousDisplayAlerts    End If    Application.StatusBar = False    Set mLogWs = Nothing    On Error GoTo 0    Exit SubFatalError:    errorNumber = Err.Number    errorDescription = Err.Description    On Error Resume Next    If Not (mLogWs Is Nothing) Then        WriteLog 0, "エラー", "", "", _                 "エラー番号 " & errorNumber & "：" & errorDescription        FinalizeLogSheet    End If    On Error GoTo 0    MsgBox _        "処理を中止しました。" & vbCrLf & vbCrLf & _        "エラー番号：" & errorNumber & vbCrLf & _        "内容：" & errorDescription, _        vbCritical, "TL座席割り振り"    GoTo SafeExitEnd Sub'================================================================================' RGB確認マクロ'================================================================================Public Sub 選択セルのRGBを確認する()    Dim targetCell As Range    Dim directColor As Long    Dim displayColor As Long    Dim displayColorAvailable As Boolean    Dim currentModeText As String    If TypeName(Selection) <> "Range" Then        MsgBox "色を確認するセルを選択してください。", vbExclamation, "RGB確認"        Exit Sub    End If    Set targetCell = Selection.Cells(1, 1)    directColor = targetCell.Interior.Color    On Error Resume Next    Err.Clear    displayColor = targetCell.DisplayFormat.Interior.Color    displayColorAvailable = (Err.Number = 0)    Err.Clear    On Error GoTo 0    If USE_DISPLAY_FORMAT Then        currentModeText = "現在の設定：画面上の表示色を使用"    Else        currentModeText = "現在の設定：直接設定された塗りつぶし色を使用"    End If    MsgBox _        "セル：" & targetCell.Worksheet.Name & "!" & targetCell.Address(False, False) & vbCrLf & vbCrLf & _        "直接設定された色：" & ColorToRGBText(directColor) & vbCrLf & _        "画面上の表示色：" & IIf(displayColorAvailable, ColorToRGBText(displayColor), "取得できません") & vbCrLf & vbCrLf & _        currentModeText, _        vbInformation, "RGB確認"End Sub'================================================================================' 会社で変更する座席一覧'================================================================================Private Function GetTLSeatAddresses() As Collection    Dim seats As New Collection    seats.Add "F5"    seats.Add "G5"    seats.Add "H5"    seats.Add "J5"    Set GetTLSeatAddresses = seatsEnd FunctionPrivate Function GetMemberSeatAddresses() As Collection    Dim seats As New Collection    'TL固定席がすべて埋まった場合だけ使用するメンバー席を追加してください。    '不要な場合は、このまま何も追加しなくて構いません。    '    '例：    'seats.Add "B10"    'seats.Add "C10"    'seats.Add "D10"    Set GetMemberSeatAddresses = seatsEnd Function'================================================================================' 1日分の割り当て'================================================================================Private Sub AssignTLsForDay( _    ByVal dayWs As Worksheet, _    ByVal dayNumber As Long, _    ByVal workingTLs As Object, _    ByVal tlSeats As Collection, _    ByVal memberSeats As Collection, _    ByVal lastWorkDay As Object, _    ByVal lastSeat As Object, _    ByVal lastSeatDay As Object, _    ByRef assignedCount As Long, _    ByRef unassignedCount As Long)    Dim assignedToday As Object    Dim candidates As Collection    Dim remainingPeople As Collection    Dim availableSeats As Collection    Dim personKey As Variant    Dim keyText As String    Dim seatAddress As String    Dim personName As String    Set assignedToday = NewTextDictionary()    If workingTLs.Count = 0 Then        WriteLog dayNumber, "情報", "", "", "出勤扱いのTLはいません。"        Exit Sub    End If    '--------------------------------------------------------------------------    ' 第1優先：前日も出勤し、前日に使ったTL固定席がある人    '--------------------------------------------------------------------------    For Each personKey In workingTLs.Keys        keyText = CStr(personKey)        If Not assignedToday.Exists(keyText) Then            If DictionaryLong(lastWorkDay, keyText, 0) = dayNumber - 1 _               And DictionaryLong(lastSeatDay, keyText, 0) = dayNumber - 1 _               And lastSeat.Exists(keyText) Then                seatAddress = CStr(lastSeat(keyText))                If IsAddressInCollection(seatAddress, tlSeats) Then                    personName = CStr(workingTLs(keyText))                    If TryAssignToTLSeat(dayWs, seatAddress, personName) Then                        RecordAssignment assignedToday, keyText, seatAddress, _                                         dayNumber, personName, _                                         "前日と同じTL固定席", assignedCount                    Else                        WriteLog dayNumber, "警告", personName, seatAddress, _                                 "前日と同じTL固定席を確保できなかったため、別の席を探します。"                    End If                End If            End If        End If    Next personKey    '--------------------------------------------------------------------------    ' 第2優先：本人が直近に使ったTL固定席    '同じ席を複数人が希望する場合は、より最近使った人を先に処理    '--------------------------------------------------------------------------    Set candidates = GetRecentSeatCandidates( _                        workingTLs, assignedToday, _                        lastSeat, lastSeatDay, tlSeats)    For Each personKey In candidates        keyText = CStr(personKey)        seatAddress = CStr(lastSeat(keyText))        personName = CStr(workingTLs(keyText))        If TryAssignToTLSeat(dayWs, seatAddress, personName) Then            RecordAssignment assignedToday, keyText, seatAddress, _                             dayNumber, personName, _                             "直近に使用したTL固定席", assignedCount        End If    Next personKey    '--------------------------------------------------------------------------    ' 第3優先：空いているTL固定席    '--------------------------------------------------------------------------    Set remainingPeople = GetRemainingPersonKeys(workingTLs, assignedToday)    Set remainingPeople = ShuffledCopy(remainingPeople)    Set availableSeats = GetAvailableTLSeatAddresses(dayWs, tlSeats)    Set availableSeats = ShuffledCopy(availableSeats)    Do While remainingPeople.Count > 0 And availableSeats.Count > 0        keyText = CStr(remainingPeople(1))        seatAddress = CStr(availableSeats(1))        personName = CStr(workingTLs(keyText))        If TryAssignToTLSeat(dayWs, seatAddress, personName) Then            RecordAssignment assignedToday, keyText, seatAddress, _                             dayNumber, personName, _                             "空いているTL固定席", assignedCount        End If        remainingPeople.Remove 1        availableSeats.Remove 1    Loop    '--------------------------------------------------------------------------    ' 第4優先：TL固定席が埋まった後だけ、前日と同じメンバー席    '    'メンバー席は例外用です。    '前日にメンバー席だった人でも、当日にTL固定席へ入れる場合はTL固定席を優先します。    '--------------------------------------------------------------------------    For Each personKey In workingTLs.Keys        keyText = CStr(personKey)        If Not assignedToday.Exists(keyText) Then            If DictionaryLong(lastWorkDay, keyText, 0) = dayNumber - 1 _               And DictionaryLong(lastSeatDay, keyText, 0) = dayNumber - 1 _               And lastSeat.Exists(keyText) Then                seatAddress = CStr(lastSeat(keyText))                If IsAddressInCollection(seatAddress, memberSeats) Then                    personName = CStr(workingTLs(keyText))                    If TryAssignToMemberSeat(dayWs, seatAddress, personName) Then                        RecordAssignment assignedToday, keyText, seatAddress, _                                         dayNumber, personName, _                                         "TL席満席のため前日と同じメンバー席", assignedCount                    End If                End If            End If        End If    Next personKey    '--------------------------------------------------------------------------    ' 第5優先：直近に使ったメンバー席    '--------------------------------------------------------------------------    Set candidates = GetRecentSeatCandidates( _                        workingTLs, assignedToday, _                        lastSeat, lastSeatDay, memberSeats)    For Each personKey In candidates        keyText = CStr(personKey)        seatAddress = CStr(lastSeat(keyText))        personName = CStr(workingTLs(keyText))        If TryAssignToMemberSeat(dayWs, seatAddress, personName) Then            RecordAssignment assignedToday, keyText, seatAddress, _                             dayNumber, personName, _                             "TL席満席のため直近のメンバー席", assignedCount        End If    Next personKey    '--------------------------------------------------------------------------    ' 第6優先：その他の空いているメンバー席    '--------------------------------------------------------------------------    Set remainingPeople = GetRemainingPersonKeys(workingTLs, assignedToday)    Set remainingPeople = ShuffledCopy(remainingPeople)    Set availableSeats = GetAvailableMemberSeatAddresses(dayWs, memberSeats)    Set availableSeats = ShuffledCopy(availableSeats)    Do While remainingPeople.Count > 0 And availableSeats.Count > 0        keyText = CStr(remainingPeople(1))        seatAddress = CStr(availableSeats(1))        personName = CStr(workingTLs(keyText))        If TryAssignToMemberSeat(dayWs, seatAddress, personName) Then            RecordAssignment assignedToday, keyText, seatAddress, _                             dayNumber, personName, _                             "TL席満席のため空いているメンバー席", assignedCount        End If        remainingPeople.Remove 1        availableSeats.Remove 1    Loop    '--------------------------------------------------------------------------    ' 当日の座席履歴を更新し、割り当てできなかった人をログへ出す    '--------------------------------------------------------------------------    For Each personKey In assignedToday.Keys        keyText = CStr(personKey)        PutDictionaryValue lastSeat, keyText, CStr(assignedToday(keyText))        PutDictionaryValue lastSeatDay, keyText, dayNumber    Next personKey    For Each personKey In workingTLs.Keys        keyText = CStr(personKey)        If Not assignedToday.Exists(keyText) Then            unassignedCount = unassignedCount + 1            WriteLog dayNumber, "未割当", CStr(workingTLs(keyText)), "", _                     "TL固定席と空いているメンバー席のどちらも確保できませんでした。"        End If    Next personKeyEnd SubPrivate Sub RecordAssignment( _    ByVal assignedToday As Object, _    ByVal personKey As String, _    ByVal seatAddress As String, _    ByVal dayNumber As Long, _    ByVal personName As String, _    ByVal reasonText As String, _    ByRef assignedCount As Long)    assignedToday.Add personKey, seatAddress    assignedCount = assignedCount + 1    WriteLog dayNumber, "割当", personName, seatAddress, reasonTextEnd Sub'================================================================================' 既存割り当ての読み込み'================================================================================Private Sub ReadExistingAssignments( _    ByVal dayWs As Worksheet, _    ByVal dayNumber As Long, _    ByVal workingTLs As Object, _    ByVal tlSeats As Collection, _    ByVal memberSeats As Collection, _    ByVal lastSeat As Object, _    ByVal lastSeatDay As Object)    Dim seenPeople As Object    Set seenPeople = NewTextDictionary()    ReadSeatCollection dayWs, dayNumber, workingTLs, tlSeats, _                       lastSeat, lastSeatDay, seenPeople, "TL固定席"    ReadSeatCollection dayWs, dayNumber, workingTLs, memberSeats, _                       lastSeat, lastSeatDay, seenPeople, "メンバー席"End SubPrivate Sub ReadSeatCollection( _    ByVal dayWs As Worksheet, _    ByVal dayNumber As Long, _    ByVal workingTLs As Object, _    ByVal seatAddresses As Collection, _    ByVal lastSeat As Object, _    ByVal lastSeatDay As Object, _    ByVal seenPeople As Object, _    ByVal seatTypeText As String)    Dim item As Variant    Dim seatAddress As String    Dim personName As String    Dim personKey As String    For Each item In seatAddresses        seatAddress = CStr(item)        personName = GetCellText(GetSeatCell(dayWs, seatAddress))        personKey = NormalizePersonKey(personName)        If Len(personKey) > 0 Then            If workingTLs.Exists(personKey) Then                If seenPeople.Exists(personKey) Then                    WriteLog dayNumber, "警告", CStr(workingTLs(personKey)), _                             seatAddress, _                             "同じTL名が複数の設定席にあります。先に見つかった席を履歴として使用します。"                Else                    seenPeople.Add personKey, True                    PutDictionaryValue lastSeat, personKey, seatAddress                    PutDictionaryValue lastSeatDay, personKey, dayNumber                    WriteLog dayNumber, "履歴", CStr(workingTLs(personKey)), _                             seatAddress, _                             "既存の" & seatTypeText & "割り当てを履歴として読み込みました。"                End If            End If        End If    Next itemEnd Sub'================================================================================' 割り当て候補・空席の取得'================================================================================Private Function GetRecentSeatCandidates( _    ByVal workingTLs As Object, _    ByVal assignedToday As Object, _    ByVal lastSeat As Object, _    ByVal lastSeatDay As Object, _    ByVal targetSeatAddresses As Collection) As Collection    Dim result As New Collection    Dim personKey As Variant    Dim keyText As String    Dim seatAddress As String    For Each personKey In workingTLs.Keys        keyText = CStr(personKey)        If Not assignedToday.Exists(keyText) Then            If lastSeat.Exists(keyText) And lastSeatDay.Exists(keyText) Then                seatAddress = CStr(lastSeat(keyText))                If IsAddressInCollection(seatAddress, targetSeatAddresses) Then                    InsertCandidateByRecentDay result, keyText, lastSeatDay                End If            End If        End If    Next personKey    Set GetRecentSeatCandidates = resultEnd FunctionPrivate Sub InsertCandidateByRecentDay( _    ByVal result As Collection, _    ByVal personKey As String, _    ByVal lastSeatDay As Object)    Dim insertPosition As Long    Dim existingKey As String    Dim candidateDay As Long    Dim existingDay As Long    candidateDay = DictionaryLong(lastSeatDay, personKey, 0)    For insertPosition = 1 To result.Count        existingKey = CStr(result(insertPosition))        existingDay = DictionaryLong(lastSeatDay, existingKey, 0)        If candidateDay > existingDay Then            result.Add Item:=personKey, Before:=insertPosition            Exit Sub        End If    Next insertPosition    result.Add personKeyEnd SubPrivate Function GetRemainingPersonKeys( _    ByVal workingTLs As Object, _    ByVal assignedToday As Object) As Collection    Dim result As New Collection    Dim personKey As Variant    For Each personKey In workingTLs.Keys        If Not assignedToday.Exists(CStr(personKey)) Then            result.Add CStr(personKey)        End If    Next personKey    Set GetRemainingPersonKeys = resultEnd FunctionPrivate Function GetAvailableTLSeatAddresses( _    ByVal dayWs As Worksheet, _    ByVal tlSeats As Collection) As Collection    Dim result As New Collection    Dim item As Variant    Dim seatAddress As String    For Each item In tlSeats        seatAddress = CStr(item)        If IsTLSeatAvailable(dayWs, seatAddress) Then            result.Add seatAddress        End If    Next item    Set GetAvailableTLSeatAddresses = resultEnd FunctionPrivate Function GetAvailableMemberSeatAddresses( _    ByVal dayWs As Worksheet, _    ByVal memberSeats As Collection) As Collection    Dim result As New Collection    Dim item As Variant    Dim seatAddress As String    For Each item In memberSeats        seatAddress = CStr(item)        If IsMemberSeatAvailable(dayWs, seatAddress) Then            result.Add seatAddress        End If    Next item    Set GetAvailableMemberSeatAddresses = resultEnd FunctionPrivate Function ShuffledCopy(ByVal source As Collection) As Collection    Dim remaining As New Collection    Dim result As New Collection    Dim item As Variant    Dim pickIndex As Long    For Each item In source        remaining.Add item    Next item    If Not RANDOMIZE_UNPREFERRED_ASSIGNMENTS Then        For Each item In remaining            result.Add item        Next item        Set ShuffledCopy = result        Exit Function    End If    Do While remaining.Count > 0        pickIndex = Int(Rnd() * remaining.Count) + 1        result.Add remaining(pickIndex)        remaining.Remove pickIndex    Loop    Set ShuffledCopy = resultEnd Function'================================================================================' セルへの書き込み・空席判定'================================================================================Private Function TryAssignToTLSeat( _    ByVal dayWs As Worksheet, _    ByVal seatAddress As String, _    ByVal personName As String) As Boolean    Dim seatCell As Range    If Not IsTLSeatAvailable(dayWs, seatAddress) Then Exit Function    Set seatCell = GetSeatCell(dayWs, seatAddress)    seatCell.Value2 = personName    TryAssignToTLSeat = TrueEnd FunctionPrivate Function TryAssignToMemberSeat( _    ByVal dayWs As Worksheet, _    ByVal seatAddress As String, _    ByVal personName As String) As Boolean    Dim seatCell As Range    If Not IsMemberSeatAvailable(dayWs, seatAddress) Then Exit Function    Set seatCell = GetSeatCell(dayWs, seatAddress)    seatCell.Value2 = personName    TryAssignToMemberSeat = TrueEnd FunctionPrivate Function IsTLSeatAvailable( _    ByVal dayWs As Worksheet, _    ByVal seatAddress As String) As Boolean    Dim seatCell As Range    Set seatCell = GetSeatCell(dayWs, seatAddress)    IsTLSeatAvailable = _        (StrComp(Trim$(GetCellText(seatCell)), Trim$(TL_MARKER), vbTextCompare) = 0)End FunctionPrivate Function IsMemberSeatAvailable( _    ByVal dayWs As Worksheet, _    ByVal seatAddress As String) As Boolean    Dim seatCell As Range    Dim currentText As String    Set seatCell = GetSeatCell(dayWs, seatAddress)    currentText = Trim$(GetCellText(seatCell))    IsMemberSeatAvailable = _        (Len(currentText) = 0) _        Or (StrComp(currentText, Trim$(MEMBER_EMPTY_MARKER), vbTextCompare) = 0)End FunctionPrivate Function AreAllTLSeatsMarkers( _    ByVal dayWs As Worksheet, _    ByVal tlSeats As Collection) As Boolean    Dim item As Variant    If tlSeats.Count = 0 Then Exit Function    For Each item In tlSeats        If Not IsTLSeatAvailable(dayWs, CStr(item)) Then Exit Function    Next item    AreAllTLSeatsMarkers = TrueEnd FunctionPrivate Function HasAnyTLInMemberSeats( _    ByVal dayWs As Worksheet, _    ByVal tlNames As Object, _    ByVal memberSeats As Collection) As Boolean    Dim item As Variant    Dim personKey As String    For Each item In memberSeats        personKey = NormalizePersonKey( _                        GetCellText(GetSeatCell(dayWs, CStr(item))))        If Len(personKey) > 0 Then            If tlNames.Exists(personKey) Then                HasAnyTLInMemberSeats = True                Exit Function            End If        End If    Next itemEnd FunctionPrivate Function GetSeatCell( _    ByVal ws As Worksheet, _    ByVal seatAddress As String) As Range    Dim targetCell As Range    Set targetCell = ws.Range(seatAddress)    If targetCell.MergeCells Then        Set targetCell = targetCell.MergeArea.Cells(1, 1)    Else        Set targetCell = targetCell.Cells(1, 1)    End If    Set GetSeatCell = targetCellEnd FunctionPrivate Function IsAddressInCollection( _    ByVal seatAddress As String, _    ByVal seatAddresses As Collection) As Boolean    Dim item As Variant    Dim targetAddress As String    targetAddress = NormalizeAddress(seatAddress)    For Each item In seatAddresses        If NormalizeAddress(CStr(item)) = targetAddress Then            IsAddressInCollection = True            Exit Function        End If    Next itemEnd Function'================================================================================' TL一覧・シフト表の読み込み'================================================================================Private Function BuildTLDictionary(ByVal tlListWs As Worksheet) As Object    Dim result As Object    Dim lastRow As Long    Dim rowNumber As Long    Dim personName As String    Dim personKey As String    Set result = NewTextDictionary()    lastRow = tlListWs.Cells(tlListWs.Rows.Count, TL_LIST_NAME_COL).End(xlUp).Row    For rowNumber = TL_LIST_FIRST_ROW To lastRow        personName = CleanDisplayName( _                        GetCellText(tlListWs.Cells(rowNumber, TL_LIST_NAME_COL)))        personKey = NormalizePersonKey(personName)        If Len(personKey) > 0 Then            If result.Exists(personKey) Then                WriteLog 0, "警告", personName, "", _                         "TL一覧に同一人物と判定される氏名が重複しています。最初の登録を使用します。"            Else                result.Add personKey, personName            End If        End If    Next rowNumber    Set BuildTLDictionary = resultEnd FunctionPrivate Function BuildShiftNameRowDictionary(ByVal shiftWs As Worksheet) As Object    Dim result As Object    Dim lastRow As Long    Dim rowNumber As Long    Dim personName As String    Dim personKey As String    Set result = NewTextDictionary()    lastRow = shiftWs.Cells(shiftWs.Rows.Count, SHIFT_NAME_COL).End(xlUp).Row    For rowNumber = SHIFT_FIRST_NAME_ROW To lastRow        personName = CleanDisplayName( _                        GetCellText(shiftWs.Cells(rowNumber, SHIFT_NAME_COL)))        personKey = NormalizePersonKey(personName)        If Len(personKey) > 0 Then            If result.Exists(personKey) Then                WriteLog 0, "警告", personName, "", _                         "シフト表の氏名列に同一人物と判定される氏名が重複しています。最初の行を使用します。"            Else                result.Add personKey, rowNumber            End If        End If    Next rowNumber    Set BuildShiftNameRowDictionary = resultEnd FunctionPrivate Function BuildWorkingTLDictionary( _    ByVal shiftWs As Worksheet, _    ByVal dateColumn As Long, _    ByVal tlNames As Object, _    ByVal shiftNameRows As Object) As Object    Dim result As Object    Dim personKey As Variant    Dim shiftCell As Range    Set result = NewTextDictionary()    For Each personKey In tlNames.Keys        If shiftNameRows.Exists(CStr(personKey)) Then            Set shiftCell = shiftWs.Cells( _                                CLng(shiftNameRows(CStr(personKey))), _                                dateColumn)            If IsWorkingShiftCell(shiftCell) Then                result.Add CStr(personKey), CStr(tlNames(personKey))            End If        End If    Next personKey    Set BuildWorkingTLDictionary = resultEnd FunctionPrivate Function BuildShiftDateColumnDictionary( _    ByVal shiftWs As Worksheet) As Object    Dim result As Object    Dim lastColumn As Long    Dim columnNumber As Long    Dim dayNumber As Long    Set result = NewTextDictionary()    lastColumn = shiftWs.Cells(SHIFT_DATE_ROW, shiftWs.Columns.Count).End(xlToLeft).Column    For columnNumber = SHIFT_FIRST_DATE_COL To lastColumn        If TryGetDayFromDateHeader( _                shiftWs.Cells(SHIFT_DATE_ROW, columnNumber), dayNumber) Then            If result.Exists(CStr(dayNumber)) Then                WriteLog dayNumber, "警告", "", "", _                         "シフト表の日付見出しが重複しています。左側の列を使用します。"            Else                result.Add CStr(dayNumber), columnNumber            End If        End If    Next columnNumber    Set BuildShiftDateColumnDictionary = resultEnd FunctionPrivate Function BuildDaySheetDictionary(ByVal wb As Workbook) As Object    Dim result As Object    Dim ws As Worksheet    Dim dayNumber As Long    Set result = NewTextDictionary()    For Each ws In wb.Worksheets        If StrComp(ws.Name, SHIFT_SHEET_NAME, vbTextCompare) <> 0 _           And StrComp(ws.Name, TL_LIST_SHEET_NAME, vbTextCompare) <> 0 _           And StrComp(ws.Name, LOG_SHEET_NAME, vbTextCompare) <> 0 Then            If TryGetDayFromSheetName(ws.Name, dayNumber) Then                If result.Exists(CStr(dayNumber)) Then                    WriteLog dayNumber, "警告", "", "", _                             "同じ日を表す日付シートが複数あります。先に見つかった「" & _                             CStr(result(CStr(dayNumber))) & "」を使用します。"                Else                    result.Add CStr(dayNumber), ws.Name                End If            End If        End If    Next ws    Set BuildDaySheetDictionary = resultEnd Function'================================================================================' シフト判定・在宅色判定'================================================================================Private Function IsWorkingShiftCell(ByVal shiftCell As Range) As Boolean    Dim shiftText As String    If IsError(shiftCell.Value) Then Exit Function    If IsRemoteWorkCell(shiftCell) Then Exit Function    shiftText = Trim$(CStr(shiftCell.Value2))    If Len(shiftText) = 0 Then Exit Function    IsWorkingShiftCell = IsAlphabetAndNumberShiftCode(shiftText)End FunctionPrivate Function IsAlphabetAndNumberShiftCode(ByVal sourceText As String) As Boolean    Dim textValue As String    Dim characterValue As String    Dim characterCode As Long    Dim position As Long    Dim hasLetter As Boolean    Dim hasNumber As Boolean    Dim numberPartStarted As Boolean    textValue = Trim$(sourceText)    On Error Resume Next    textValue = StrConv(textValue, vbNarrow)    On Error GoTo 0    If Len(textValue) < 2 Then Exit Function    For position = 1 To Len(textValue)        characterValue = Mid$(textValue, position, 1)        characterCode = AscW(characterValue)        If (characterCode >= 65 And characterCode <= 90) _           Or (characterCode >= 97 And characterCode <= 122) Then            If numberPartStarted Then Exit Function            hasLetter = True        ElseIf characterCode >= 48 And characterCode <= 57 Then            If Not hasLetter Then Exit Function            numberPartStarted = True            hasNumber = True        Else            Exit Function        End If    Next position    IsAlphabetAndNumberShiftCode = hasLetter And hasNumberEnd FunctionPrivate Function IsRemoteWorkCell(ByVal targetCell As Range) As Boolean    Dim actualColor As Long    Dim remoteColor As Long    actualColor = GetConfiguredFillColor(targetCell)    remoteColor = RGB(REMOTE_COLOR_R, REMOTE_COLOR_G, REMOTE_COLOR_B)    IsRemoteWorkCell = (actualColor = remoteColor)End FunctionPrivate Function GetConfiguredFillColor(ByVal targetCell As Range) As Long    On Error GoTo DirectColorFallback    If USE_DISPLAY_FORMAT Then        GetConfiguredFillColor = targetCell.DisplayFormat.Interior.Color    Else        GetConfiguredFillColor = targetCell.Interior.Color    End If    Exit FunctionDirectColorFallback:    Err.Clear    GetConfiguredFillColor = targetCell.Interior.ColorEnd FunctionPrivate Function ColorToRGBText(ByVal colorValue As Long) As String    Dim redValue As Long    Dim greenValue As Long    Dim blueValue As Long    redValue = colorValue Mod 256    greenValue = (colorValue \ 256) Mod 256    blueValue = (colorValue \ 65536) Mod 256    ColorToRGBText = _        "RGB(" & redValue & ", " & greenValue & ", " & blueValue & ")"End Function'================================================================================' 日付の解析'================================================================================Private Function TryGetDayFromSheetName( _    ByVal sheetName As String, _    ByRef dayNumber As Long) As Boolean    Dim textValue As String    textValue = Trim$(sheetName)    If Len(textValue) > 1 Then        If Right$(textValue, 1) = "日" Then            textValue = Left$(textValue, Len(textValue) - 1)        End If    End If    If Not IsDigitsOnly(textValue) Then Exit Function    dayNumber = CLng(textValue)    If dayNumber < 1 Or dayNumber > 31 Then Exit Function    TryGetDayFromSheetName = TrueEnd FunctionPrivate Function TryGetDayFromDateHeader( _    ByVal headerCell As Range, _    ByRef dayNumber As Long) As Boolean    Dim valueData As Variant    Dim numericValue As Double    Dim dateValue As Date    Dim textValue As String    valueData = headerCell.Value    If IsError(valueData) Or IsEmpty(valueData) Then Exit Function    '1～31の数値は、そのまま日として扱う    If IsNumeric(valueData) Then        numericValue = CDbl(valueData)        If numericValue = Fix(numericValue) Then            If numericValue >= 1 And numericValue <= 31 Then                dayNumber = CLng(numericValue)                TryGetDayFromDateHeader = True                Exit Function            End If        End If    End If    'Excelの日付または日付文字列    If IsDate(valueData) Then        dateValue = CDate(valueData)        If TARGET_YEAR > 0 Then            If Year(dateValue) <> TARGET_YEAR Then Exit Function        End If        If TARGET_MONTH > 0 Then            If Month(dateValue) <> TARGET_MONTH Then Exit Function        End If        dayNumber = Day(dateValue)        TryGetDayFromDateHeader = True        Exit Function    End If    '「12日」のような文字列    textValue = Trim$(CStr(valueData))    If Len(textValue) > 1 Then        If Right$(textValue, 1) = "日" Then            textValue = Left$(textValue, Len(textValue) - 1)        End If    End If    If IsDigitsOnly(textValue) Then        dayNumber = CLng(textValue)        If dayNumber >= 1 And dayNumber <= 31 Then            TryGetDayFromDateHeader = True        End If    End IfEnd FunctionPrivate Function IsDigitsOnly(ByVal sourceText As String) As Boolean    Dim position As Long    Dim characterCode As Long    If Len(sourceText) = 0 Then Exit Function    For position = 1 To Len(sourceText)        characterCode = AscW(Mid$(sourceText, position, 1))        If characterCode < 48 Or characterCode > 57 Then Exit Function    Next position    IsDigitsOnly = TrueEnd Function'================================================================================' 設定検証'================================================================================Private Function ValidateSettings( _    ByVal wb As Workbook, _    ByVal tlSeats As Collection, _    ByVal memberSeats As Collection, _    ByRef errorMessage As String) As Boolean    Dim testWs As Worksheet    Dim seenAddresses As Object    Dim item As Variant    Dim normalizedAddress As String    Dim testCell As Range    If Not WorksheetExists(wb, SHIFT_SHEET_NAME) Then        errorMessage = "シフト表シート「" & SHIFT_SHEET_NAME & "」がありません。"        Exit Function    End If    If Not WorksheetExists(wb, TL_LIST_SHEET_NAME) Then        errorMessage = "TL一覧シート「" & TL_LIST_SHEET_NAME & "」がありません。"        Exit Function    End If    If StrComp(SHIFT_SHEET_NAME, TL_LIST_SHEET_NAME, vbTextCompare) = 0 Then        errorMessage = "シフト表とTL一覧のシート名が同じです。"        Exit Function    End If    If StrComp(LOG_SHEET_NAME, SHIFT_SHEET_NAME, vbTextCompare) = 0 _       Or StrComp(LOG_SHEET_NAME, TL_LIST_SHEET_NAME, vbTextCompare) = 0 Then        errorMessage = "ログシート名が、シフト表またはTL一覧のシート名と重複しています。"        Exit Function    End If    If SHIFT_DATE_ROW < 1 _       Or SHIFT_NAME_COL < 1 _       Or SHIFT_FIRST_NAME_ROW < 1 _       Or SHIFT_FIRST_DATE_COL < 1 _       Or TL_LIST_NAME_COL < 1 _       Or TL_LIST_FIRST_ROW < 1 Then        errorMessage = "行番号・列番号の設定には1以上を指定してください。"        Exit Function    End If    If TARGET_YEAR < 0 Then        errorMessage = "TARGET_YEARは0以上で指定してください。"        Exit Function    End If    If TARGET_MONTH < 0 Or TARGET_MONTH > 12 Then        errorMessage = "TARGET_MONTHは0～12で指定してください。"        Exit Function    End If    If REMOTE_COLOR_R < 0 Or REMOTE_COLOR_R > 255 _       Or REMOTE_COLOR_G < 0 Or REMOTE_COLOR_G > 255 _       Or REMOTE_COLOR_B < 0 Or REMOTE_COLOR_B > 255 Then        errorMessage = "在宅色のR・G・Bには0～255を指定してください。"        Exit Function    End If    If Len(Trim$(TL_MARKER)) = 0 Then        errorMessage = "TL_MARKERを空白にはできません。"        Exit Function    End If    If tlSeats.Count = 0 Then        errorMessage = "TL固定席が1つも設定されていません。"        Exit Function    End If    Set testWs = wb.Worksheets(SHIFT_SHEET_NAME)    Set seenAddresses = NewTextDictionary()    For Each item In tlSeats        normalizedAddress = NormalizeAddress(CStr(item))        If Len(normalizedAddress) = 0 Then            errorMessage = "TL固定席に空のセル番地があります。"            Exit Function        End If        If seenAddresses.Exists(normalizedAddress) Then            errorMessage = "TL固定席のセル番地「" & CStr(item) & "」が重複しています。"            Exit Function        End If        Set testCell = Nothing        On Error Resume Next        Set testCell = testWs.Range(CStr(item))        On Error GoTo 0        If testCell Is Nothing Then            errorMessage = "TL固定席のセル番地「" & CStr(item) & "」が正しくありません。"            Exit Function        End If        seenAddresses.Add normalizedAddress, "TL"    Next item    For Each item In memberSeats        normalizedAddress = NormalizeAddress(CStr(item))        If Len(normalizedAddress) = 0 Then            errorMessage = "メンバー席に空のセル番地があります。"            Exit Function        End If        If seenAddresses.Exists(normalizedAddress) Then            errorMessage = "座席のセル番地「" & CStr(item) & "」が重複しています。"            Exit Function        End If        Set testCell = Nothing        On Error Resume Next        Set testCell = testWs.Range(CStr(item))        On Error GoTo 0        If testCell Is Nothing Then            errorMessage = "メンバー席のセル番地「" & CStr(item) & "」が正しくありません。"            Exit Function        End If        seenAddresses.Add normalizedAddress, "MEMBER"    Next item    ValidateSettings = TrueEnd Function'================================================================================' ログ'================================================================================Private Function PrepareLogSheet(ByVal wb As Workbook) As Worksheet    Dim logWs As Worksheet    If WorksheetExists(wb, LOG_SHEET_NAME) Then        Set logWs = wb.Worksheets(LOG_SHEET_NAME)        logWs.Cells.Clear    Else        Set logWs = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))        logWs.Name = LOG_SHEET_NAME    End If    logWs.Cells(1, 1).Value2 = "実行日時"    logWs.Cells(1, 2).Value2 = "日"    logWs.Cells(1, 3).Value2 = "区分"    logWs.Cells(1, 4).Value2 = "氏名"    logWs.Cells(1, 5).Value2 = "座席"    logWs.Cells(1, 6).Value2 = "内容"    logWs.Rows(1).Font.Bold = True    Set PrepareLogSheet = logWsEnd FunctionPrivate Sub WriteLog( _    ByVal dayNumber As Long, _    ByVal categoryText As String, _    ByVal personName As String, _    ByVal seatAddress As String, _    ByVal messageText As String)    If mLogWs Is Nothing Then Exit Sub    mLogWs.Cells(mLogNextRow, 1).Value = Now    If dayNumber > 0 Then        mLogWs.Cells(mLogNextRow, 2).Value2 = dayNumber    End If    mLogWs.Cells(mLogNextRow, 3).Value2 = categoryText    mLogWs.Cells(mLogNextRow, 4).Value2 = personName    mLogWs.Cells(mLogNextRow, 5).Value2 = seatAddress    mLogWs.Cells(mLogNextRow, 6).Value2 = messageText    mLogNextRow = mLogNextRow + 1End SubPrivate Sub FinalizeLogSheet()    If mLogWs Is Nothing Then Exit Sub    With mLogWs        .Columns(1).NumberFormatLocal = "yyyy/mm/dd hh:mm:ss"        .Columns("A:F").AutoFit    End WithEnd Sub'================================================================================' 共通処理'================================================================================Private Function NewTextDictionary() As Object    Dim result As Object    Set result = CreateObject("Scripting.Dictionary")    result.CompareMode = vbTextCompare    Set NewTextDictionary = resultEnd FunctionPrivate Sub PutDictionaryValue( _    ByVal dictionaryObject As Object, _    ByVal keyText As String, _    ByVal valueData As Variant)    If dictionaryObject.Exists(keyText) Then        dictionaryObject(keyText) = valueData    Else        dictionaryObject.Add keyText, valueData    End IfEnd SubPrivate Function DictionaryLong( _    ByVal dictionaryObject As Object, _    ByVal keyText As String, _    ByVal defaultValue As Long) As Long    If dictionaryObject.Exists(keyText) Then        DictionaryLong = CLng(dictionaryObject(keyText))    Else        DictionaryLong = defaultValue    End IfEnd FunctionPrivate Function WorksheetExists( _    ByVal wb As Workbook, _    ByVal sheetName As String) As Boolean    Dim ws As Worksheet    On Error Resume Next    Set ws = wb.Worksheets(sheetName)    WorksheetExists = Not (ws Is Nothing)    On Error GoTo 0End FunctionPrivate Function GetCellText(ByVal targetCell As Range) As String    If IsError(targetCell.Value) Then        GetCellText = ""    Else        GetCellText = CStr(targetCell.Value2)    End IfEnd FunctionPrivate Function CleanDisplayName(ByVal sourceText As String) As String    Dim result As String    result = Trim$(sourceText)    Do While Len(result) > 0 And Left$(result, 1) = "　"        result = Mid$(result, 2)    Loop    Do While Len(result) > 0 And Right$(result, 1) = "　"        result = Left$(result, Len(result) - 1)    Loop    CleanDisplayName = resultEnd FunctionPrivate Function NormalizePersonKey(ByVal personName As String) As String    Dim result As String    result = CleanDisplayName(personName)    result = Replace$(result, " ", "")    result = Replace$(result, "　", "")    result = Replace$(result, vbTab, "")    NormalizePersonKey = resultEnd FunctionPrivate Function NormalizeAddress(ByVal seatAddress As String) As String    Dim result As String    result = Trim$(seatAddress)    result = Replace$(result, "$", "")    result = UCase$(result)    NormalizeAddress = resultEnd Function