😁
T04_VBAプロシージャ一覧シリーズ 今から使える業務改善用VBA4｜各エクセルファイルのシートの飛び地セルを一括更新｜
この記事について
A05で集約した飛び地セル値（Valueシート）を一括編集して、元のエクエルファイルのシートへ一括更新 VBAシートモジュールのコードです。
シートモジュールに貼り付けるだけで動作します。環境構築は不要です。
機能の概要：
- 【A14】2段階ワークフローで「集約 → 編集 → 元のシートを更新」を完結
-
Phase1（Set）：MappingシートとValueシートを掛け合わせて
ReWriteSheetValue雛形を生成（アドレス行／値行の交互配置） - 手動編集：ユーザーが値行のセルを直接編集
- Phase2（Execute）：編集後の値を元エクセルファイルの飛び地セルを一括更新
-
Phase1（Set）：MappingシートとValueシートを掛け合わせて
- ハイパーリンクから元エクセルファイルパスを自動取得 → ファイルごと開いて該当セルへ書込
- 書込失敗ファイルは赤字マーカーで可視化
―――――――――――――――――――――――――――――――――――
処理フロー
―――――――――――――――――――――――――――――――――――
[A05] CollectExcelSheet
↓ Mappingシート（シート名・セル番地）
↓ Valueシート（集約された飛び地値）
[A14 Phase1] sA14_SetReWriteSheetValue
↓ ReWriteSheetValue雛形（アドレス行／値行の交互配置）
[手動編集] ユーザーが値行を編集
↓
[A14 Phase2] sA14_ExecuteReWriteSheetValue
↓ 元のエクセルファイルのシートを一括更新
[完了] 元ファイルが編集後の値で更新される
―――――――――――――――――――――――――――――――――――
※前提：事前に A05_CollectExcelSheet（記事T02） でMapping/Valueシートが整備されている必要があります。
※逐次、コードの改良を行っていきます。詳しい使い方は別の記事で紹介していきます。
収録プロシージャ
【Run系】ボタンに割り当てて実行するプロシージャ
Run_A14_ReWriteSheetValue Phase選択InputBoxで Set/Execute を分岐実行
Run_sA14_SetReWriteSheetValue Phase1雛形作成のみ単独実行
Run_sA14_ExecuteReWriteSheetValue Phase2書込実行のみ単独実行
【A14】飛び地セル一括更新
A14_ReWriteSheetValue 本体（Phaseディスパッチャ）
sA14_SetReWriteSheetValue Phase1：Mapping×Value→ReWriteSheetValue雛形作成
sA14_ExecuteReWriteSheetValue Phase2：編集後値を元エクセルへ書戻し
sA14_EnsureSheet 指定名のシートを取得（無ければ作成）
sA14_CopyHyperlink セルのハイパーリンクを別セルへ複製
sA14_GetHyperlinkAddress セルのハイパーリンクからファイルパスを取得
lngWriteCountForFile 1ファイルあたりの書込件数をカウント
sA14_MarkFailedFile 書込失敗ファイル行に赤字マーカーを付与
【Set系】独立ファンクション（複数プロシージャから共通利用）
Set_DesktopPath デスクトップパス取得
Set_FolderName パスからフォルダ名抽出
Set_FileDialogFolderPicker フォルダを1つ選択
Set_FileDialogFolderPickers 複数フォルダを選択
Set_FileDialogFoldersFilesPicker フォルダ＋ファイル複数選択
Set_SheetDefaultFormat シート共通書式（フォント・配置）を一括適用
Set_ColorPalette ★全A系プロシージャ共通カラーパレット一括設定
Set_DefaultFormatVars シート共通デフォルト書式変数の値設定
命名規則及び用語の定義
Run_ : ボタンに割り当てるプロシージャ（初期設定＋本体呼び出し）
Axx_ : A系統のメインプロシージャ（2桁番号）
sAxx_ : 各メインのサブプロシージャ
Set_ : 複数プロシージャから共通利用する独立ファンクション
m_ : モジュールレベルPrivate変数
CST_ : ローカルConst定数
ProcXX : プロシージャ内のコード番地（修正・査読の共通言語）
str/lng/bln/obj/ws/dbl : 変数の型を示す接頭辞
正統処理：
正統処理（Orthodox Processing）とは、メインプロシージャの目的を達成するために順序通りに実行される省略不可能な一連のサブプロシージャのこと。
各ステップが成功（True）すれば次のステップへ進み、本流が一直線に貫かれる。
分岐処理：
分岐処理（Branch Processing）とは、正統処理の本流から枝分かれして実行される条件付き・選択的なサブプロシージャのこと。
ユーザーの選択（InputBox/MsgBox）、正統処理が失敗（False）した際のエラーフォールバック、または設定フラグの真偽値によって発動の可否が決まり、該当条件に当てはまらなければスキップされる。実行されなくてもメインプロシージャの主目的は達成可能であり、副次機能・補助機能・回復処理として本流に付随する。
【A14の2段階ワークフロー】
Phase1：sA14_SetReWriteSheetValue 雛形作成（Mapping × Value → ReWriteSheetValue）
交互配置：アドレス行（青系）／値行（黄系）
Phase2：sA14_ExecuteReWriteSheetValue 書込実行（編集値→元エクセル）
失敗ファイルは赤字マーカーで可視化
【データ構造の比喩】
麺（Value） : Cells.Value 配列でCOM一括取得・書込
スープ（NumberFormat）: 個別取得・書込（書式情報）
→ 値と書式を別配列で扱う「ダブル配列パターン」
→ A05からの一貫した設計思想
使い方
■ 前提（事前に実行済みであること）
STEP0 A05_CollectExcelSheet（記事T02）を実行
→ Mappingシート整備（シート名・セル番地登録）
→ Valueシート整備（飛び地値が集約済み）
■ A14 一括書戻しを使う場合
STEP1 ExcelのVBAエディタ（Alt+F11）を開く
STEP2 シートモジュール（Sheet1等）にコードを貼り付ける
STEP3 Run_A14_ReWriteSheetValue を実行
→ Phase選択InputBox表示
→ "1" 入力：Phase1（雛形作成）
STEP4 ReWriteSheetValueシートが自動生成される
（アドレス行／値行の交互配置・色分け済み）
STEP5 ユーザーが値行のセルを直接編集
→ 編集したい値だけ書き換え
STEP6 もう一度 Run_A14_ReWriteSheetValue を実行
→ "2" 入力：Phase2（書込実行）
→ 元エクセルファイルへ一括書戻し
→ 失敗ファイルは赤字マーカー表示
■ 単独実行（上級者向け）
Run_sA14_SetReWriteSheetValue Phase1のみ実行
Run_sA14_ExecuteReWriteSheetValue Phase2のみ実行
コード全文
Option Explicit
' ===========================================================================
' | ZENNブログ記事 その3 - 飛び地セル一括書戻し（A14: ReWriteSheetValue）
' | ファイル: ZENN記事_その3_VBA0+A14_一括書戻し.cls
' | 作成日: 20260506
' | Ver.0105 [20260506] 機能番号01・更新番号05
' | 内容: VBA0(共通) + A14: 飛び地セル一括書戻し（A05のValue→元エクセル）
' | 使い方: シートモジュールにそのまま貼り付ければ動作
' | 前提: A05_CollectExcelSheet で Mapping/Value シート整備済み
' ===========================================================================
' === A14 Ver.変更履歴 ======================================================
' Ver.0100 [20260506] 初版（Mapping × Value → ReWriteSheetValue 生成）
' Ver.0101 [20260506] レイアウト改訂（アドレス行+入力行 交互配置）
' Ver.0102 [20260506] 入力行Value既存値プリセット（A05ダブル配列パターン）
' Ver.0103 [20260506] Proc06再実行時merge残留対策（Cells.UnMerge追加）
' Ver.0104 [20260506] Proc08-4 C+空欄症状対策（per-cell書込みに変更）
' Ver.0105 [20260506] Debug.Print デバッグコード削除（クリーンアップ）
' ===========================================================================
Private m_lngColorDepth1 As Long ' メインフォルダを示す（深さ1）背景色
Private m_lngColorDepth2 As Long ' サブフォルダを示す（深さ2）背景色
Private m_lngColorDepth3 As Long ' サブサブフォルダを示す（深さ3）背景色
Private m_lngColorDepth4 As Long ' サブサブサブ以下（深さ4+）背景色
Private m_blnShowScreen As Boolean ' VBA実行画面表示（True=表示/False=抑制）
Private m_strPrefixCode As String ' A04_コピー時のファイル名先頭文字
Private m_lngColorHeader As Long ' ヘッダー背景色
Private m_blnAdvancedPicker As Boolean ' 上級者向け複数のフォルダおよびファイル選択（False=単一選択/True=複数可）
'A01_ListFilesの初期設定で使用。False（初期値）ならフォルダ単位で1回選択、Trueなら複数のフォルダとファイルを選択可能にする。
'--------------------------------------------
Private m_lngInteriorColorDeduplication1 As Long ' 重複判定_背景色：重複無しの場合のセル背景色
Private m_lngInteriorColorDeduplication2 As Long ' 重複判定_背景色：2個の場合のセル背景色
Private m_lngInteriorColorDeduplication3 As Long ' 重複判定_背景色：3～5個の場合のセル背景色
Private m_lngInteriorColorDeduplication4 As Long ' 重複判定_背景色：6個以上の場合のセル背景色
Private m_lngFontColorDeduplication1 As Long ' 重複判定_文字色：重複無しの場合の文字色
Private m_lngFontColorDeduplication2 As Long ' 重複判定_文字色：2個の場合の文字色
Private m_lngFontColorDeduplication3 As Long ' 重複判定_文字色：3～5個の場合の文字色
Private m_lngFontColorDeduplication4 As Long ' 重複判定_文字色：6個以上の場合の文字色
'--------------------------------------------
Private m_lngA05ColorMappingHeader As Long ' A05 Mapping雛形_ヘッダー背景色（薄黄色）
Private m_lngA05ColorMappingSample As Long ' A05 Mapping雛形_サンプル行背景色（薄青）
Private m_lngA05ColorMappingSheetName As Long ' A05 Mapping雛形_シート名列文字色（赤字）
Private m_lngA05ColorMappingBorder As Long ' A05 Mapping雛形_罫線色（灰色）
Private m_lngA05ColorMappingHelp As Long ' A05 Mapping雛形_使い方解説背景色（薄ベージュ）
Private m_lngA05ColorValueHeader As Long ' A05 Valueシート_ヘッダー背景色（薄黄色）
'--------------------------------------------
Private m_lngA07ColorFileRow As Long ' A07 シート管理_Row1ファイル名行の背景色（薄青）
Private m_lngA07ColorLabel As Long ' A07 シート管理_A列ラベル（現在名/変更後）の背景色（薄黄）
Private m_lngA07ColorAfterCell As Long ' A07 シート管理_Row3「変更後」入力欄の背景色（薄ベージュ）
Private m_lngA07ColorChanged As Long ' A08 リネーム成功セルの背景色（淡緑）
Private m_lngA07ColorError As Long ' A08 開けない/重複等のエラー表示色（薄赤）
'--------------------------------------------
' === A01 H列「MD有無」の対象外（ファイル行）書式 ===
' [追加:20260429] フォルダ以外（ファイル行）の対象外表示用
Private m_strA01MdCheckOutOfScope As String ' 対象外表示文字（"―" 全角ダッシュ）
Private m_lngA01MdCheckOutOfScopeFontColor As Long ' 対象外文字色（灰色25% RGB(191,191,191)）
Private m_lngA01MdCheckOutOfScopeAlign As Long ' 対象外配置（xlRight）
'--------------------------------------------
' === シート共通デフォルト書式 ============================================
' どの A系プロシージャからも参照される共通の見た目設定
' Set_SheetDefaultFormat(ws) でシート全体に一括適用する
Private m_strDefaultFontName As String ' シート共通：フォント名（例 "Century"）
Private m_lngDefaultFontSize As Long ' シート共通：フォントサイズ（例 14）
Private m_lngDefaultVAlign As Long ' シート共通：縦方向配置（xlCenter等）
Private m_lngDefaultHAlign As Long ' シート共通：横方向配置（xlCenter等）
'--------------------------------------------
' === シート共通カラーパレット（連番プリセット） ============================
' Run_系プロシージャで番号ごとに用途を割り当てる
' 例：m_FontColor01 = 入力欄文字色、m_BgColor01 = ヘッダー背景色 など
' 4色プリセット（必要に応じて拡張可）
Private m_FontColor01 As Long ' フォント色01
Private m_FontColor02 As Long ' フォント色02
Private m_FontColor03 As Long ' フォント色03
Private m_FontColor04 As Long ' フォント色04
Private m_BgColor01 As Long ' 背景色01
Private m_BgColor02 As Long ' 背景色02
Private m_BgColor03 As Long ' 背景色03
Private m_BgColor04 As Long ' 背景色04
'--------------------------------------------
' === シート管理5モード専用カラー＋プルダウン文言 [追加:20260503] ===========
' HTMLプロトタイプ（シート管理_5モード_prototype.html）と完全同期
' 操作1-1: シート名変更 緑系（安全な書換）
' 操作1-2: シート名削除 赤系（危険操作）
' 操作1-3: シート名集約 橙系（抽出）
' 操作2-1: 値と値の書式 紫系（変換固定）
' 操作2-2: シート書式リセット 青緑系（構造変更、4処理統合）
Private m_strMode1_1_Placeholder As String ' "/変更後シート名入力/" 操作1-1初期プリフィル
Private m_strMode1_2_YesText As String ' "はい(削除)"
Private m_strMode1_3_YesText As String ' "はい(集約対象)"
Private m_strMode2_1_YesText As String ' "はい(値固定)"
Private m_strMode2_2_YesText As String ' "はい(書式リセット)" [仕様変更:20260503]
Private m_lngMode1_1_Bg As Long ' 1-1 背景色（緑系）
Private m_lngMode1_1_Font As Long ' 1-1 文字色
Private m_lngMode1_2_Bg As Long ' 1-2 背景色（赤系）
Private m_lngMode1_2_Font As Long ' 1-2 文字色
Private m_lngMode1_3_Bg As Long ' 1-3 背景色（橙系）
Private m_lngMode1_3_Font As Long ' 1-3 文字色
Private m_lngMode2_1_Bg As Long ' 2-1 背景色（紫系）
Private m_lngMode2_1_Font As Long ' 2-1 文字色
Private m_lngMode2_2_Bg As Long ' 2-2 背景色（青緑系）
Private m_lngMode2_2_Font As Long ' 2-2 文字色
'--------------------------------------------
' === A12 シート書式リセット 4フラグ [追加:20260503] [Const化:20260503] ===
' モジュールレベル定数として宣言＋初期値を一行完結で固定化（動的変更なし）
' ★この True/False を直接書き換えれば挙動が切替わる★
' Run_A12_ResetSheetFormat 初期化不要、A12_ResetSheetFormat 本体で直接参照
Private Const CST_blnA12_Unmerge As Boolean = True ' ①結合解除（Cells.UnMerge）
Private Const CST_blnA12_ClearBgColor As Boolean = True ' ②セル背景色無し（ColorIndex=xlNone）
Private Const CST_blnA12_ResetFontColor As Boolean = True ' ③セル文字色黒（Font.Color=RGB(0,0,0)）
Private Const CST_blnA12_UnfreezePanes As Boolean = True ' ④ウィンドウ枠の固定解除（FreezePanes=False）
'--------------------------------------------
' === A05 Valueシート空欄行削除 必須入力個数 [追加:20260503] ===
' モジュールレベル定数として宣言＋初期値を一行完結で固定化
' Valueシート各行のC列以降（CntColNum個）について、
' 入力済みセル数 < CST_lngA05_KeepRowNum なら、その行を削除する
' ★この数値を直接書き換えれば判定基準が切替わる★
Private Const CST_lngA05_KeepRowNum As Long = 2 ' 必須入力個数（既定2個、これ未満は空欄行扱いで削除）
'--------------------------------------------
' === A06 等差展開 組ごと交互背景色 [追加:20260503] ===
' モジュールレベル定数として宣言＋初期値を一行完結で固定化
' 1組目（奇数組）= 背景色なし（xlNone）/ 2組目（偶数組）= CST_lngA06_AlternateBg（薄黄）
' 視認性向上のため組ごとの境界をストライプで強調する
Private Const CST_lngA06_AlternateBg As Long = 14809343 ' RGB(255, 248, 225) 薄黄（偶数組の背景色）
'--------------------------------------------
' =============================================================
' | A14のプロシージャ群: Mapping × Value 一括書戻し
' =============================================================
' ────────────────────────────────────────────────────────────
' ■ 実行プロシージャRun系（A14メイン + Phase別単独実行）
' ────────────────────────────────────────────────────────────
' ===================================
' Run_A14_ReWriteSheetValue
' A14_ReWriteSheetValue の実行用プロシージャ
' Phase選択InputBoxで Set or Execute を選ぶ
' ===================================
' [更新日:20260506]
Public Sub Run_A14_ReWriteSheetValue()
'Proc01_カラーパレット一括設定（全A系統で共通）
Call Set_ColorPalette
'Proc02_本体プロシージャを呼び出し
Me.A14_ReWriteSheetValue
End Sub
' ===================================
' Run_sA14_SetReWriteSheetValue
' sA14_SetReWriteSheetValue の単独実行用 実行プロシージャRun系
' Mapping × Value → ReWriteSheetValue 雛形作成
' ===================================
' [更新日:20260506]
Public Sub Run_sA14_SetReWriteSheetValue()
'Proc01_カラーパレット一括設定
Call Set_ColorPalette
'Proc02_本体プロシージャを呼び出し
Me.sA14_SetReWriteSheetValue
End Sub
' ===================================
' Run_sA14_ExecuteReWriteSheetValue
' sA14_ExecuteReWriteSheetValue の単独実行用 実行プロシージャRun系
' ReWriteSheetValue の編集値を元のエクセルファイルのシートへ一括更新
' ===================================
' [更新日:20260506]
Public Sub Run_sA14_ExecuteReWriteSheetValue()
'Proc01_カラーパレット一括設定
Call Set_ColorPalette
'Proc02_本体プロシージャを呼び出し
Me.sA14_ExecuteReWriteSheetValue
End Sub
' ────────────────────────────────────────────────────────────
' ■ A系メイン（A14本体プロシージャ＋直下にsA系サブを正統処理順で配置）
' ────────────────────────────────────────────────────────────
' ===================================
' A14_ReWriteSheetValue（Ver.0105）（メインプロシージャ）
' Phase選択dispatcher
' Ver.変更履歴はファイル冒頭の === Ver.変更履歴 === ブロックを参照
' ===================================
' [更新日:20260506]
Sub A14_ReWriteSheetValue()
'2段階ワークフロー:
' Phase1=雛形作成（Set） / Phase2手動編集 / Phase3=書込実行（Execute）
'本メインは Phase1/3 を InputBox で選択して該当sAを呼ぶdispatcher
Dim strPhase As String
'Proc01_Phase選択InputBox
strPhase = InputBox( _
"A14 ReWriteSheetValue 一括書戻し" & vbCrLf & vbCrLf & _
"[1] ReWriteSheetValue 雛形作成（Mapping × Value → 編集用雛形）" & vbCrLf & _
"[2] 元エクセルへ書込実行（編集後の値を一括書戻し）" & vbCrLf & vbCrLf & _
"事前に A05_CollectExcelSheet で Mapping/Value 整備済が前提です。" & vbCrLf & _
"1 または 2 を入力してください（キャンセルで終了）", _
"A14 Phase選択", "1")
'Proc02_Phase別dispatch
Select Case Trim(strPhase)
Case "1"
Call sA14_SetReWriteSheetValue
Case "2"
Call sA14_ExecuteReWriteSheetValue
Case ""
Exit Sub ' キャンセル
Case Else
MsgBox "1 または 2 を入力してください。", vbExclamation, "A14 Phase選択"
End Select
End Sub
' ────────────────────────────────────────────────────────────
' ■ 正統処理: Phase1 雛形作成（Mapping × Value → ReWriteSheetValue）
' ────────────────────────────────────────────────────────────
' ===================================
' sA14_SetReWriteSheetValue
' Mapping シートと Value シートを掛け合わせて
' ReWriteSheetValue シートの雛形を作成
' - Value 各行に対し、対応する Mapping 行（セルアドレス）を直前に挿入
' - 結果: アドレス行 / 値行 / アドレス行 / 値行 … の交互配置
' ===================================
' [更新日:20260506]
Sub sA14_SetReWriteSheetValue()
' ローカル定数
Const CST_SHEET_MAPPING As String = "Mapping"
Const CST_SHEET_VALUE As String = "Value"
Const CST_SHEET_REWRITE As String = "ReWriteSheetValue"
' [削除:20260506] CST_ADDR_ROW_MARKER ─ アドレス行はファイル名（リンク）で識別する方式に変更
Dim wsMapping As Worksheet
Dim wsValue As Worksheet
Dim wsReWrite As Worksheet
Dim dictMap As Object ' {sheetName: Collection of {RowIndex, Addresses}}
Dim dictCounter As Object ' {fileName|sheetName: 現在のスロットIndex}
Dim lngLastColM As Long
Dim lngLastRowM As Long
Dim lngLastRowV As Long
Dim arrHeaders As Variant
Dim r As Long
Dim j As Long
Dim strSheetName As String
Dim strFileName As String
Dim strKey As String
Dim colSlots As Collection
Dim dictSlot As Object
Dim arrAddresses As Variant
Dim lngOutRow As Long
Dim lngSlotIndex As Long
Dim lngOldCalc As Long
Dim varVal As Variant
Dim arrRowValues As Variant ' [追加:20260506] 麺=Value配列（COM一括取得）
Dim arrRowFormats() As String ' [追加:20260506] スープ=NumberFormat配列（個別取得）
Dim lngRowWidth As Long ' [追加:20260506] 1行の列数
'Proc00_パフォーマンス設定
On Error GoTo ErrHandler
lngOldCalc = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False
'Proc01_Mappingシート存在確認
On Error Resume Next
Set wsMapping = Nothing
Set wsMapping = ThisWorkbook.Worksheets(CST_SHEET_MAPPING)
On Error GoTo ErrHandler
If wsMapping Is Nothing Then
MsgBox "Mapping シートが見つかりません。" & vbCrLf & _
"先に A05_CollectExcelSheet を実行してください。", _
vbExclamation, "A14 Set Phase1"
GoTo Cleanup
End If
'Proc02_Valueシート存在確認
On Error Resume Next
Set wsValue = Nothing
Set wsValue = ThisWorkbook.Worksheets(CST_SHEET_VALUE)
On Error GoTo ErrHandler
If wsValue Is Nothing Then
MsgBox "Value シートが見つかりません。" & vbCrLf & _
"先に A05_CollectExcelSheet を実行してください。", _
vbExclamation, "A14 Set Phase1"
GoTo Cleanup
End If
'Proc03_Mapping最終列・行
lngLastColM = wsMapping.Cells(1, wsMapping.Columns.Count).End(xlToLeft).Column
lngLastRowM = wsMapping.Cells(wsMapping.Rows.Count, 1).End(xlUp).Row
If lngLastRowM < 2 Or lngLastColM < 2 Then
MsgBox "Mapping にデータがありません（2行目以降のシート名+セル位置が必須）。", _
vbExclamation, "A14 Set Phase1"
GoTo Cleanup
End If
'Proc04_Value最終行
lngLastRowV = wsValue.Cells(wsValue.Rows.Count, 1).End(xlUp).Row
If lngLastRowV < 2 Then
MsgBox "Value にデータがありません。先に A05_CollectExcelSheet を実行してください。", _
vbExclamation, "A14 Set Phase1"
GoTo Cleanup
End If
'Proc05_Mapping辞書化（SheetName → Collection of {RowIndex, Addresses}）
Set dictMap = CreateObject("Scripting.Dictionary")
For r = 2 To lngLastRowM
strSheetName = CStr(wsMapping.Cells(r, 1).Value)
If strSheetName = "" Then GoTo NextMapRow
' アドレス配列構築（B列以降）
ReDim arrAddresses(1 To lngLastColM - 1)
For j = 2 To lngLastColM
arrAddresses(j - 1) = CStr(wsMapping.Cells(r, j).Value)
Next j
' SheetName ごとに Collection を持たせる
If Not dictMap.Exists(strSheetName) Then
Set colSlots = New Collection
dictMap.Add strSheetName, colSlots
Else
Set colSlots = dictMap(strSheetName)
End If
Set dictSlot = CreateObject("Scripting.Dictionary")
dictSlot("RowIndex") = r
dictSlot("Addresses") = arrAddresses
colSlots.Add dictSlot
NextMapRow:
Next r
'Proc06_ReWriteSheetValue 確保とクリア
' ★[修正:20260506-3] 既存merge状態を確実に解除してから値・書式書込
' 前回実行で残ったmergeがあるとProc08-4の A+B結合が誤動作するため、
' UnMerge → Clear の順で完全初期化する
Set wsReWrite = sA14_EnsureSheet(CST_SHEET_REWRITE)
On Error Resume Next
wsReWrite.Cells.UnMerge
On Error GoTo ErrHandler
wsReWrite.Cells.Clear
'Proc07_ヘッダー行コピー（Valueのヘッダーをそのまま使用）
arrHeaders = wsValue.Range(wsValue.Cells(1, 1), _
wsValue.Cells(1, lngLastColM + 1)).Value
wsReWrite.Range(wsReWrite.Cells(1, 1), _
wsReWrite.Cells(1, lngLastColM + 1)).Value = arrHeaders
With wsReWrite.Rows(1)
.Font.Bold = True
.Interior.Color = m_lngA05ColorValueHeader
End With
'Proc08_Value各行を走査して交互配置
Set dictCounter = CreateObject("Scripting.Dictionary")
lngOutRow = 2
For r = 2 To lngLastRowV
strFileName = CStr(wsValue.Cells(r, 1).Value)
strSheetName = CStr(wsValue.Cells(r, 2).Value)
If strFileName = "" Or strSheetName = "" Then GoTo NextValRow
'Proc08-1_(file,sheet) 単位のスロットIndex取得
strKey = strFileName & "|" & strSheetName
If dictCounter.Exists(strKey) Then
dictCounter(strKey) = dictCounter(strKey) + 1
Else
dictCounter.Add strKey, 1
End If
lngSlotIndex = dictCounter(strKey)
'Proc08-2_対応するMappingスロット取得
If Not dictMap.Exists(strSheetName) Then GoTo NextValRow
Set colSlots = dictMap(strSheetName)
If lngSlotIndex < 1 Or lngSlotIndex > colSlots.Count Then
' Mapping行数を超えた → スロット無し（ファイル切替などで起き得る）
' 既存スロット数で循環させる（modulo）
lngSlotIndex = ((lngSlotIndex - 1) Mod colSlots.Count) + 1
dictCounter(strKey) = lngSlotIndex
End If
Set dictSlot = colSlots(lngSlotIndex)
arrAddresses = dictSlot("Addresses")
'Proc08-3_アドレス行を出力（A05パターン: 配列1=値一括書込・配列2=書式個別書込）
' ★[仕様変更:20260506] アドレス行=緑系背景、ファイル名のリンクをCol Aに配置
' ★[A05整合:20260506] 配列1（値）= [ファイル名, シート名, addr1, addr2…] を一括書込
' 配列2（書式）= 全セル "@"（文字列固定）を個別書込
lngRowWidth = lngLastColM + 1
' 配列1（麺=値）構築
ReDim arrRowValues(1 To lngRowWidth)
arrRowValues(1) = strFileName
arrRowValues(2) = strSheetName
For j = LBound(arrAddresses) To UBound(arrAddresses)
arrRowValues(2 + j) = arrAddresses(j)
Next j
' 配列2（スープ=書式）構築: アドレス行は全セル文字列固定
ReDim arrRowFormats(1 To lngRowWidth)
For j = 1 To lngRowWidth
arrRowFormats(j) = "@"
Next j
' 配列1（値）を Range一括書込（COM 1回）
wsReWrite.Range(wsReWrite.Cells(lngOutRow, 1), _
wsReWrite.Cells(lngOutRow, lngRowWidth)).Value = arrRowValues
' 配列2（書式）をセル毎に個別セット（NumberFormatは配列代入不可）
For j = 1 To lngRowWidth
wsReWrite.Cells(lngOutRow, j).NumberFormat = arrRowFormats(j)
Next j
' Col A をハイパーリンク化（Valueのファイル名リンクを再現）
Call sA14_CopyHyperlink(wsValue, r, wsReWrite, lngOutRow)
With wsReWrite.Range(wsReWrite.Cells(lngOutRow, 1), _
wsReWrite.Cells(lngOutRow, lngRowWidth))
.Interior.Color = m_BgColor04 ' 淡緑: アドレス行（編集対象外）
.Font.Italic = False
.Font.Color = RGB(0, 0, 0) ' 黒
End With
' Col C+（セルアドレス部分）はやや薄い文字色＋イタリックで「編集対象外」を視覚化
With wsReWrite.Range(wsReWrite.Cells(lngOutRow, 3), _
wsReWrite.Cells(lngOutRow, lngRowWidth))
.Font.Italic = True
.Font.Color = RGB(80, 80, 80)
End With
lngOutRow = lngOutRow + 1
'Proc08-4_更新後の値入力行（A05パターン: 配列1=Value既存値・配列2=Value由来書式）
' ★[仕様変更:20260506-2] Value既存値をC+に予め入力（ユーザーが上書き更新する方式）
' ★[A05整合:20260506] 配列1（値）= ValueのC+を一括書込
' 配列2（書式）= ValueのNumberFormatを個別書込
' - A+B を横方向に結合し「上書き更新後の値」を中央揃えで表示
' - C列以降はValueシートの該当行の値を予め入力済み
' - ユーザーは必要なセルのみ上書き編集 → Phase3で元エクセルへ反映
' - 背景色なし（白）でどんどん編集できる視認性
' A+B 結合してラベル表示
With wsReWrite.Range(wsReWrite.Cells(lngOutRow, 1), _
wsReWrite.Cells(lngOutRow, 2))
.Merge
.Value = "上書き更新後の値"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Italic = False
.Font.Color = RGB(120, 120, 120) ' 灰色: ラベル感
.Interior.ColorIndex = xlNone ' 背景色なし
End With
' 配列1（麺=値）構築: ValueシートのC+の値を取得（C列開始のサイズ）
' 配列2（スープ=書式）構築: ValueシートのC+のNumberFormat
' ※C+の列数 = lngRowWidth - 2（Col A,B分を除く）
Dim lngColCInputCount As Long
lngColCInputCount = lngRowWidth - 2
ReDim arrRowValues(1 To lngColCInputCount)
ReDim arrRowFormats(1 To lngColCInputCount)
For j = 1 To lngColCInputCount
arrRowValues(j) = wsValue.Cells(r, j + 2).Value
arrRowFormats(j) = wsValue.Cells(r, j + 2).NumberFormat
Next j
' ★[修正:Ver.0104:20260506] バルク書込みが効かないケースに対応するため
' per-cell ループ書込みに変更（A05のスープと同じ個別書込）
' ※C+の値が空欄になる症状の根本対策（動作確認済 Ver.0105:20260506）
' Range.Resize.Value 一括書込が A:B merge 直後の同じ行で機能しない事象あり
' ★[Ver.0105:20260506] Debug.Print デバッグコード削除（動作確認完了）
For j = 1 To lngColCInputCount
wsReWrite.Cells(lngOutRow, j + 2).Value = arrRowValues(j)
wsReWrite.Cells(lngOutRow, j + 2).NumberFormat = arrRowFormats(j)
Next j
' Col C+ 背景色なし（白）で入力エリアを視覚化
With wsReWrite.Range(wsReWrite.Cells(lngOutRow, 3), _
wsReWrite.Cells(lngOutRow, lngRowWidth))
.Interior.ColorIndex = xlNone
End With
lngOutRow = lngOutRow + 1
NextValRow:
Next r
'Proc09_罫線
If lngOutRow > 2 Then
With wsReWrite.Range(wsReWrite.Cells(1, 1), _
wsReWrite.Cells(lngOutRow - 1, lngLastColM + 1))
.Borders.LineStyle = xlContinuous
End With
End If
'Proc10_列幅自動調整
wsReWrite.Columns("A:Z").AutoFit
'Proc11_完了通知
MsgBox "ReWriteSheetValue 雛形を作成しました。" & vbCrLf & vbCrLf & _
"出力行数: " & (lngOutRow - 1) & " 行" & vbCrLf & _
"（アドレス行（淡緑） + 上書き更新後の値入力行（白） の交互配置）" & vbCrLf & vbCrLf & _
"次の手順:" & vbCrLf & _
" 1. 入力行（白）C列以降には Valueシートの既存値が予め入力されている" & vbCrLf & _
" 必要なセルだけ上書きで編集（書式は元のまま継承済）" & vbCrLf & _
" ★空欄にしたセルは書戻しスキップ＝元エクセル維持" & vbCrLf & _
" 2. 編集完了後、Run_sA14_ExecuteReWriteSheetValue を実行" & vbCrLf & _
" 3. 元エクセルファイルへ一括書戻し", _
vbInformation, "A14 Phase1 完了"
GoTo Cleanup
ErrHandler:
MsgBox "エラー: " & Err.Number & " - " & Err.Description, vbCritical, "A14 Set Phase1"
Cleanup:
Application.ScreenUpdating = True
Application.Calculation = lngOldCalc
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
' ────────────────────────────────────────────────────────────
' ■ 正統処理: Phase3 書込実行（ReWriteSheetValue → 元エクセル）
' ────────────────────────────────────────────────────────────
' ===================================
' sA14_ExecuteReWriteSheetValue
' ReWriteSheetValue の編集値を対応する元エクセルファイルのシートへ一括更新
' - 値行のCol Aハイパーリンクからファイルパスを取得
' - 直前のアドレス行から書込先セルアドレスを取得
' - シート名はCol B
' - 各エクセルを開き、指定セルに書込→保存→閉じる
' ===================================
' [更新日:20260506]
Sub sA14_ExecuteReWriteSheetValue()
' ローカル定数
Const CST_SHEET_REWRITE As String = "ReWriteSheetValue"
' [削除:20260506] CST_ADDR_ROW_MARKER ─ アドレス行はファイル名（リンク）で識別する方式に変更
Dim wsReWrite As Worksheet
Dim lngLastRow As Long
Dim lngLastCol As Long
Dim r As Long
Dim j As Long
Dim strSheetName As String
Dim strFilePath As String
Dim arrAddresses() As String
Dim arrNewValues() As Variant
Dim wbSrc As Workbook
Dim wsSrc As Worksheet
Dim rngTarget As Range
Dim lngOldCalc As Long
Dim lngTotalFiles As Long
Dim lngFileIndex As Long
Dim dictByFile As Object ' {filePath: Collection of {SheetName, Addr, Value}}
Dim varKey As Variant
Dim colWrites As Collection
Dim dictWrite As Object
Dim varW As Variant
Dim lngAnswer As Long
Dim lngWriteCount As Long
Dim lngFailCount As Long
Dim lngOpenFailed As Long
Dim strReport As String
Dim dblStartTime As Double
Dim dblElapsed As Double
'Proc00_開始時刻
dblStartTime = Timer
'Proc00-1_パフォーマンス設定
On Error GoTo ErrHandler
lngOldCalc = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False
'Proc01_ReWriteSheetValueシート確認
On Error Resume Next
Set wsReWrite = Nothing
Set wsReWrite = ThisWorkbook.Worksheets(CST_SHEET_REWRITE)
On Error GoTo ErrHandler
If wsReWrite Is Nothing Then
MsgBox "ReWriteSheetValue シートがありません。" & vbCrLf & _
"先に Run_sA14_SetReWriteSheetValue を実行してください。", _
vbExclamation, "A14 Execute Phase3"
GoTo Cleanup
End If
lngLastRow = wsReWrite.Cells(wsReWrite.Rows.Count, 2).End(xlUp).Row
lngLastCol = wsReWrite.Cells(1, wsReWrite.Columns.Count).End(xlToLeft).Column
If lngLastRow < 3 Or lngLastCol < 3 Then
MsgBox "ReWriteSheetValue にデータがありません。", _
vbExclamation, "A14 Execute Phase3"
GoTo Cleanup
End If
'Proc02_実行確認MsgBox
lngAnswer = MsgBox( _
"ReWriteSheetValue の編集値を元エクセルに一括書戻します。" & vbCrLf & vbCrLf & _
"実行行数: 約 " & ((lngLastRow - 1) \ 2) & " 件（値行）" & vbCrLf & vbCrLf & _
"★この操作は元ファイルを変更します。事前にバックアップを推奨。" & vbCrLf & vbCrLf & _
"実行しますか？", _
vbYesNo + vbExclamation, "A14 Execute 実行確認")
If lngAnswer <> vbYes Then GoTo Cleanup
'Proc03_書込タスクをファイル別Dictionaryに集約（ファイルを1回だけ開いて全書込）
' ★[仕様変更:20260506] 新レイアウト対応
' - アドレス行: Col A にハイパーリンク（=ファイルパス）、Col B=Sheet、Col C+=セルアドレス
' - 入力行: A+B結合「上書き更新後の値」、Col C+=ユーザー入力新値
' - 入力行のC列以降が空欄の場合は元エクセルを上書きせずスキップ
Set dictByFile = CreateObject("Scripting.Dictionary")
r = 2
Do While r <= lngLastRow
' アドレス行か判定（Col A にハイパーリンクあり）
strFilePath = sA14_GetHyperlinkAddress(wsReWrite.Cells(r, 1))
If strFilePath = "" Then
' ハイパーリンク無 → アドレス行ではない（入力行 or 空行）→ 次行へ
r = r + 1
GoTo NextScanRow
End If
' アドレス行: SheetName と セルアドレス配列を取得
strSheetName = CStr(wsReWrite.Cells(r, 2).Value)
ReDim arrAddresses(3 To lngLastCol)
For j = 3 To lngLastCol
arrAddresses(j) = CStr(wsReWrite.Cells(r, j).Value)
Next j
' 直後の入力行: 新値配列を取得（C列以降）
If r + 1 > lngLastRow Then Exit Do
ReDim arrNewValues(3 To lngLastCol)
For j = 3 To lngLastCol
arrNewValues(j) = wsReWrite.Cells(r + 1, j).Value
Next j
' 書込タスク = (SheetName, Addr, NewValue) を file毎に集約
If Not dictByFile.Exists(strFilePath) Then
Set colWrites = New Collection
dictByFile.Add strFilePath, colWrites
Else
Set colWrites = dictByFile(strFilePath)
End If
For j = 3 To lngLastCol
If arrAddresses(j) <> "" Then
' ★入力値が空欄なら書込スキップ（元エクセルを上書きしない）
If IsEmpty(arrNewValues(j)) Or Trim(CStr(arrNewValues(j))) = "" Then
' Skip: ユーザーが入力していない箇所は元値維持
Else
Set dictWrite = CreateObject("Scripting.Dictionary")
dictWrite("SheetName") = strSheetName
dictWrite("Address") = arrAddresses(j)
dictWrite("Value") = arrNewValues(j)
dictWrite("RowInRW") = r + 1 ' ReWriteSheetValueでの行（フィードバック表示用）
dictWrite("ColInRW") = j
colWrites.Add dictWrite
End If
End If
Next j
r = r + 2
NextScanRow:
Loop
lngTotalFiles = dictByFile.Count
If lngTotalFiles = 0 Then
MsgBox "書込対象が見つかりませんでした。", vbInformation, "A14 Execute Phase3"
GoTo Cleanup
End If
'Proc04_ファイル毎にループして書込
lngFileIndex = 0
lngWriteCount = 0
lngFailCount = 0
lngOpenFailed = 0
For Each varKey In dictByFile.Keys
lngFileIndex = lngFileIndex + 1
strFilePath = CStr(varKey)
Set colWrites = dictByFile(strFilePath)
' ステータスバー更新
Application.StatusBar = "A14書戻し中... [" & lngFileIndex & "/" & lngTotalFiles & "] " & _
CreateObject("Scripting.FileSystemObject").GetFileName(strFilePath)
DoEvents
'Proc04-1_ファイルを開く（書込モード）
On Error Resume Next
Set wbSrc = Nothing
Set wbSrc = Workbooks.Open(strFilePath, ReadOnly:=False, UpdateLinks:=0)
If wbSrc Is Nothing Then
Err.Clear
On Error GoTo ErrHandler
lngOpenFailed = lngOpenFailed + lngWriteCountForFile(colWrites)
' エラー記録
Call sA14_MarkFailedFile(wsReWrite, colWrites, "### 開けない")
GoTo NextFile
End If
Err.Clear
On Error GoTo ErrHandler
'Proc04-2_各書込タスクを実行
For Each varW In colWrites
Set dictWrite = varW
On Error Resume Next
Set wsSrc = Nothing
Set wsSrc = wbSrc.Worksheets(CStr(dictWrite("SheetName")))
If wsSrc Is Nothing Then
Err.Clear
wsReWrite.Cells(dictWrite("RowInRW"), dictWrite("ColInRW")).Interior.Color = RGB(255, 220, 220)
wsReWrite.Cells(dictWrite("RowInRW"), dictWrite("ColInRW")).AddComment "シート無し: " & dictWrite("SheetName")
lngFailCount = lngFailCount + 1
Else
Set rngTarget = Nothing
Set rngTarget = wsSrc.Range(CStr(dictWrite("Address")))
If rngTarget Is Nothing Then
Err.Clear
wsReWrite.Cells(dictWrite("RowInRW"), dictWrite("ColInRW")).Interior.Color = RGB(255, 220, 220)
lngFailCount = lngFailCount + 1
Else
rngTarget.Value = dictWrite("Value")
If Err.Number = 0 Then
wsReWrite.Cells(dictWrite("RowInRW"), dictWrite("ColInRW")).Interior.Color = m_BgColor04 ' 成功: 淡緑維持
lngWriteCount = lngWriteCount + 1
Else
Err.Clear
wsReWrite.Cells(dictWrite("RowInRW"), dictWrite("ColInRW")).Interior.Color = RGB(255, 220, 220)
lngFailCount = lngFailCount + 1
End If
End If
End If
On Error GoTo ErrHandler
Next varW
'Proc04-3_保存して閉じる
On Error Resume Next
wbSrc.Save
wbSrc.Close SaveChanges:=False
Err.Clear
On Error GoTo ErrHandler
NextFile:
Next varKey
Application.StatusBar = False
'Proc05_経過時間
dblElapsed = Timer - dblStartTime
If dblElapsed < 0 Then dblElapsed = dblElapsed + 86400
'Proc06_完了通知
strReport = "書戻し完了:" & vbCrLf & _
" 対象ファイル: " & lngTotalFiles & " 件" & vbCrLf & _
" 成功セル: " & lngWriteCount & " 件" & vbCrLf & _
" 失敗セル: " & lngFailCount & " 件" & vbCrLf
If lngOpenFailed > 0 Then
strReport = strReport & " 開けないファイル由来失敗: " & lngOpenFailed & " 件" & vbCrLf
End If
strReport = strReport & " 処理時間: " & Format(dblElapsed, "0.000") & " 秒"
MsgBox strReport, vbInformation, "A14 Phase3 完了"
GoTo Cleanup
ErrHandler:
Application.StatusBar = False
MsgBox "エラー: " & Err.Number & " - " & Err.Description, vbCritical, "A14 Execute Phase3"
Cleanup:
Application.StatusBar = False
Application.CutCopyMode = False
Application.ScreenUpdating = True
Application.Calculation = lngOldCalc
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
' ────────────────────────────────────────────────────────────
' ■ 共通サブプロシージャ（A14内部ヘルパー）
' ────────────────────────────────────────────────────────────
' ===================================
' sA14_EnsureSheet
' 指定名のシートを取得、無ければ末尾に作成
' ※ A05のsA05_EnsureSheetと同じロジック（独立実装で凝集性確保）
' ===================================
' [更新日:20260506]
Private Function sA14_EnsureSheet(strName As String) As Worksheet
Dim ws As Worksheet
'Proc01_既存シート検索
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(strName)
On Error GoTo 0
'Proc02_存在しなければ末尾に新規作成
If ws Is Nothing Then
Set ws = ThisWorkbook.Worksheets.Add( _
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
ws.Name = strName
End If
'Proc03_戻り値設定
Set sA14_EnsureSheet = ws
End Function
' ===================================
' sA14_CopyHyperlink
' Valueシートのファイル名セル（Col A）のハイパーリンクをReWriteへコピー
' ===================================
' [更新日:20260506]
Private Sub sA14_CopyHyperlink(wsSrc As Worksheet, _
lngSrcRow As Long, _
wsDst As Worksheet, _
lngDstRow As Long)
Dim hl As Hyperlink
Dim strAddr As String
Dim strDisplay As String
'Proc01_ソースセルにハイパーリンクがあるか
If wsSrc.Cells(lngSrcRow, 1).Hyperlinks.Count = 0 Then Exit Sub
'Proc02_ハイパーリンク情報取得
Set hl = wsSrc.Cells(lngSrcRow, 1).Hyperlinks(1)
strAddr = hl.Address
strDisplay = CStr(wsSrc.Cells(lngSrcRow, 1).Value)
'Proc03_既存リンク削除＆再作成
On Error Resume Next
wsDst.Cells(lngDstRow, 1).Hyperlinks.Delete
wsDst.Hyperlinks.Add _
Anchor:=wsDst.Cells(lngDstRow, 1), _
Address:=strAddr, _
TextToDisplay:=strDisplay
Err.Clear
On Error GoTo 0
End Sub
' ===================================
' sA14_GetHyperlinkAddress
' セルのハイパーリンクからアドレス（ファイルパス）を取得
' なければ "" を返す
' ===================================
' [更新日:20260506]
Private Function sA14_GetHyperlinkAddress(rng As Range) As String
'Proc01_ハイパーリンク有無チェック
If rng.Hyperlinks.Count = 0 Then
sA14_GetHyperlinkAddress = ""
Exit Function
End If
'Proc02_アドレス取得
sA14_GetHyperlinkAddress = rng.Hyperlinks(1).Address
End Function
' ===================================
' lngWriteCountForFile
' Collectionの要素数をLongで返す（簡易ヘルパー）
' ===================================
Private Function lngWriteCountForFile(col As Collection) As Long
On Error Resume Next
lngWriteCountForFile = col.Count
If Err.Number <> 0 Then lngWriteCountForFile = 0
Err.Clear
On Error GoTo 0
End Function
' ===================================
' sA14_MarkFailedFile
' ファイルが開けなかった場合、その全書込タスクの値セルを薄赤化
' ===================================
' [更新日:20260506]
Private Sub sA14_MarkFailedFile(wsReWrite As Worksheet, _
colWrites As Collection, _
strReason As String)
Dim varW As Variant
Dim dictW As Object
'Proc01_全タスクをエラー表示
For Each varW In colWrites
Set dictW = varW
On Error Resume Next
wsReWrite.Cells(dictW("RowInRW"), dictW("ColInRW")).Interior.Color = RGB(255, 220, 220)
wsReWrite.Cells(dictW("RowInRW"), dictW("ColInRW")).AddComment strReason
Err.Clear
On Error GoTo 0
Next varW
End Sub
' =============================================================
' | SET グループ: 独立ファンクション（複数プロシージャから共通利用）
' =============================================================
' ===================================
' Set_DesktopPath
' Set_系プロシージャは、様々なプロシージャから呼び出せる独立ファンクション
' デスクトップのパスを返す独立ファンクション
' 戻り値：デスクトップの絶対パス
' ===================================
' [更新日:20260428]
Function Set_DesktopPath() As String
'Proc01_WScript.Shellでデスクトップパス取得
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
Set_DesktopPath = objShell.SpecialFolders("Desktop")
Set objShell = Nothing
End Function
' ===================================
' Set_FileDialogFolderPickers
' ダイアログボックスを開き、複数のフォルダ選択を行い、パス一覧を返す独立ファンクション
' 呼び出し元プロシージャから引数として、タイトルとボタンラベルを受け取り
' strTitle ダイアログタイトル
' strPrompt ボタンラベル
' 戻り値：選択フォルダパスの配列（キャンセル時はEmpty）
' ===================================
' [更新日:20260428]
Function Set_FileDialogFolderPickers(strTitle As String, _
strPrompt As String) As Variant
Dim objDialog As FileDialog
Dim strPaths() As String
Dim lngCount As Long
Dim lngIndex As Long
'Proc01_ダイアログ初期化
Set objDialog = Application.FileDialog(msoFileDialogFolderPicker)
'Proc02_複数フォルダ選択
With objDialog
.Title = strTitle
.ButtonName = strPrompt
.AllowMultiSelect = True
If .Show <> -1 Then
Set_FileDialogFolderPickers = Empty
Exit Function
End If
lngCount = .SelectedItems.Count
ReDim strPaths(0 To lngCount - 1)
For lngIndex = 1 To lngCount
strPaths(lngIndex - 1) = .SelectedItems(lngIndex)
Next lngIndex
End With
'Proc03_戻り値設定
Set_FileDialogFolderPickers = strPaths
Set objDialog = Nothing
End Function
' ===================================
' Set_FolderName
' フォルダパスからフォルダ名を取得する独立ファンクション
' 引数：strFolderPath フォルダのフルパス
' 戻り値：フォルダ名のみ
' ===================================
' [更新日:20260428]
Function Set_FolderName(strFolderPath As String) As String
'Proc01_FSOでフォルダ名抽出
Dim objFileSystemObject As Object
Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set_FolderName = objFileSystemObject.GetFolder(strFolderPath).Name
Set objFileSystemObject = Nothing
End Function
' ===================================
' Set_SheetDefaultFormat
' シート共通のデフォルト書式（フォント名・サイズ・縦横配置）を一括適用
' Run_系で初期化済みのモジュール変数を参照する
' m_strDefaultFontName / m_lngDefaultFontSize
' m_lngDefaultVAlign / m_lngDefaultHAlign
' [修正:20260503] 未初期化フォールバック追加（実行時エラー1004回避）
' 引数：ws 適用対象のWorksheet
' ===================================
' [更新日:20260503]
Sub Set_SheetDefaultFormat(ws As Worksheet)
'Proc01_未初期化フォールバック [追加:20260503]
' Run_系を経由せずに本Subが呼ばれた場合、または初期化漏れの場合に
' ws.Cells.Font.Size = 0 で発生する 実行時エラー1004 を防ぐ
If m_strDefaultFontName = "" Or m_lngDefaultFontSize <= 0 Then
Call Set_DefaultFormatVars
End If
'Proc02_シート全セルに一括適用（エラーハンドラで安全化）
On Error Resume Next
With ws.Cells
.Font.Name = m_strDefaultFontName
.Font.Size = m_lngDefaultFontSize
.VerticalAlignment = m_lngDefaultVAlign
.HorizontalAlignment = m_lngDefaultHAlign
End With
If Err.Number <> 0 Then Err.Clear
On Error GoTo 0
End Sub
' ===================================
' Set_ColorPalette
' ★全A系プロシージャ共通のカラーパレットを一括設定する★
' この1か所を編集すれば、A01/A05/A07/A08のすべての配色が同期して切り替わる。
'
' 構成:
' ① 連番プリセット（共通プール） m_FontColor01～04 / m_BgColor01～04
' ② A系名前付き色（後方互換用、可能な限り連番プリセットへエイリアス化）
' - A01 階層色 / 重複判定色
' - A05 Mapping/Value 色
' - A07/A08 シート管理色
' - シート管理5モード（操作1-1～2-2）専用カラー [追加:20260503]
' ===================================
' [更新日:20260503]
Sub Set_ColorPalette()
'===========================================================
'【共通プール】カラーパレット連番プリセット
'===========================================================
'Proc01_フォント色01～04
m_FontColor01 = RGB( 24, 92, 55) ' 緑系：入力欄/編集中の文字色
m_FontColor02 = RGB( 0, 0, 0) ' 黒：通常文字色
m_FontColor03 = RGB(192, 0, 0) ' 濃赤：警告/エラー文字色
m_FontColor04 = RGB(255, 255, 255) ' 白：濃色背景上の反転文字色
'Proc02_背景色01～04
m_BgColor01 = RGB(217, 236, 255) ' 薄青：ヘッダー/ファイル名行
m_BgColor02 = RGB(255, 248, 225) ' 薄黄：ラベル/見出し
m_BgColor03 = RGB(255, 251, 229) ' 薄ベージュ：入力欄/補助
m_BgColor04 = RGB(212, 244, 221) ' 淡緑：成功/正常
'===========================================================
'【A系名前付き色】既存コード後方互換 ─ 新パレットに揃える
'===========================================================
'Proc03_A01 階層色（黄色四分位）
m_lngColorDepth1 = RGB(255, 192, 0) ' 100% メイン
m_lngColorDepth2 = RGB(255, 213, 64) ' 75% サブ
m_lngColorDepth3 = RGB(255, 234, 128) ' 50% サブサブ
m_lngColorDepth4 = RGB(255, 255, 192) ' 25% サブサブサブ以下
m_lngColorHeader = RGB(255, 255, 153) ' ヘッダー背景色
'Proc04_A01 重複判定色（赤系四分位）
m_lngInteriorColorDeduplication1 = RGB(255, 255, 255) ' 重複無し 背景：白
m_lngInteriorColorDeduplication2 = RGB(255, 220, 220) ' 2個 背景：薄い赤
m_lngInteriorColorDeduplication3 = RGB(255, 150, 150) ' 3～5個 背景：中赤
m_lngInteriorColorDeduplication4 = RGB(192, 0, 0) ' 6個以上 背景：濃い赤
m_lngFontColorDeduplication1 = m_FontColor02 ' 黒（連番プリセット由来）
m_lngFontColorDeduplication2 = m_FontColor02 ' 黒（連番プリセット由来）
m_lngFontColorDeduplication3 = m_FontColor02 ' 黒（連番プリセット由来）
m_lngFontColorDeduplication4 = m_FontColor04 ' 白（連番プリセット由来）
'Proc05_A05 Mapping/Value 色
m_lngA05ColorMappingHeader = RGB(255, 255, 153) ' 薄黄色：Mapping雛形ヘッダー
m_lngA05ColorMappingSample = RGB(230, 243, 255) ' 薄青：Mapping雛形サンプル行
m_lngA05ColorMappingSheetName = RGB(211, 47, 47) ' 赤字：シート名列文字色
m_lngA05ColorMappingBorder = RGB(150, 150, 150) ' 灰色：罫線色
m_lngA05ColorMappingHelp = RGB(255, 243, 205) ' 薄ベージュ：使い方解説背景
m_lngA05ColorValueHeader = RGB(255, 255, 153) ' 薄黄色：Valueシートヘッダー
'Proc06_A07/A08 シート管理色（連番プリセットへエイリアス化 ─ 統一性UP）
m_lngA07ColorFileRow = m_BgColor01 ' 薄青：Row1ファイル名行
m_lngA07ColorLabel = m_BgColor02 ' 薄黄：A列ラベル
m_lngA07ColorAfterCell = m_BgColor03 ' 薄ベージュ：Row3変更後入力欄
m_lngA07ColorChanged = m_BgColor04 ' 淡緑：A08変更成功
m_lngA07ColorError = RGB(255, 220, 220) ' 薄赤：エラー表示
'Proc07_A01 H列「MD有無」の対象外（ファイル行）書式 [追加:20260429]
m_strA01MdCheckOutOfScope = "―" ' 全角ダッシュ
m_lngA01MdCheckOutOfScopeFontColor = RGB(191, 191, 191) ' 灰色25%
m_lngA01MdCheckOutOfScopeAlign = xlRight ' 右寄せ
'Proc08_シート管理5モード専用カラー＋プルダウン文言 [追加:20260503]
' HTMLプロトタイプ（シート管理_5モード_prototype.html）と完全同期
' プルダウン文言は誤認識防止のため操作内容をカッコ書きで明示
'Proc08-1_プレースホルダー（操作1-1専用、Excel禁止文字"/"で誤実行二重防止）
m_strMode1_1_Placeholder = "/変更後シート名入力/"
'Proc08-2_5モードのプルダウン文言（誤認識防止）
m_strMode1_2_YesText = "はい(削除)"
m_strMode1_3_YesText = "はい(集約対象)"
m_strMode2_1_YesText = "はい(値固定)"
m_strMode2_2_YesText = "はい(書式リセット)" ' [変更:20260503] 結合解除→書式リセット（4機能統合）
'Proc08-3_5モードの専用カラー（HTMLと同色）
m_lngMode1_1_Bg = RGB(232, 245, 233) ' 1-1 緑系（安全な書換）
m_lngMode1_1_Font = RGB( 27, 94, 32)
m_lngMode1_2_Bg = RGB(255, 235, 238) ' 1-2 赤系（危険操作）
m_lngMode1_2_Font = RGB(183, 28, 28)
m_lngMode1_3_Bg = RGB(255, 243, 224) ' 1-3 橙系（抽出）
m_lngMode1_3_Font = RGB(230, 81, 0)
m_lngMode2_1_Bg = RGB(243, 229, 245) ' 2-1 紫系（変換固定）
m_lngMode2_1_Font = RGB( 74, 20, 140)
m_lngMode2_2_Bg = RGB(224, 242, 241) ' 2-2 青緑系（構造変更）
m_lngMode2_2_Font = RGB( 0, 77, 64)
End Sub
' ===================================
' Set_DefaultFormatVars
' ★全A系プロシージャ共通のデフォルト書式変数を一括設定する★
' フォント名/サイズ/縦横配置をRun_系の頭で1回呼ぶだけで全シートに統一適用可能。
' 実際の適用は Set_SheetDefaultFormat(ws) で行う（こちらは値の設定のみ）。
' ===================================
' [更新日:20260428]
Sub Set_DefaultFormatVars()
'Proc01_シート共通デフォルト書式の値を設定
m_strDefaultFontName = "Century"
m_lngDefaultFontSize = 14
m_lngDefaultVAlign = xlCenter
m_lngDefaultHAlign = xlCenter
End Sub
' ===================================
' [更新日:20260428]
Function Set_FileDialogFolderPicker(strTitle As String, _
strPrompt As String) As String
Dim strFolderPath As String
'Proc01_フォルダ選択ダイアログ表示
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = strTitle
.ButtonName = strPrompt
If .Show <> -1 Then
Set_FileDialogFolderPicker = ""
Exit Function
End If
strFolderPath = .SelectedItems(1)
End With
'Proc02_戻り値設定
Set_FileDialogFolderPicker = strFolderPath
End Function
' ===================================
'Set系ファンクション：シートモジュール内にある各プロシージャから呼び出すファンクション
' ===================================
' [更新日:20260428]
Function Set_FileDialogFoldersFilesPicker(strFolderTitle As String, _
strFolderPrompt As String, _
strFileTitle As String, _
strFilePrompt As String) As Variant
Dim colPaths As Collection ' 収集用コレクション
Dim lngAnswer As Long ' MsgBox戻り値
Dim i As Long ' ループカウンター
Dim j As Long ' ループカウンター（ソート用）
Dim arrPaths() As String ' 戻り値用配列
Dim strTemp As String ' ソート用一時変数
Dim strNameI As String ' ソート比較用：名前i
Dim strNameJ As String ' ソート比較用：名前j
'Proc01_コレクション初期化
Set colPaths = New Collection
'Proc02_フォルダ選択ループ
' --- フォルダ選択（繰り返し） ---
Do
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = strFolderTitle
.ButtonName = strFolderPrompt
If .Show = -1 Then
colPaths.Add .SelectedItems(1)
Else
Exit Do
End If
End With
' 上級者モードOFF時は1個選択で終了
If Not m_blnAdvancedPicker Then Exit Do
lngAnswer = MsgBox("続けて別のフォルダを選択しますか？", _
vbYesNo + vbQuestion, "フォルダ追加")
If lngAnswer = vbNo Then Exit Do
Loop
'Proc03_ファイル選択（複数可・上級者モードON時のみ）
If m_blnAdvancedPicker Then
lngAnswer = MsgBox("個別ファイルも選択しますか？", _
vbYesNo + vbQuestion, "ファイル追加")
If lngAnswer = vbYes Then
With Application.FileDialog(msoFileDialogFilePicker)
.Title = strFileTitle
.ButtonName = strFilePrompt
.AllowMultiSelect = True
If .Show = -1 Then
For i = 1 To .SelectedItems.Count
colPaths.Add .SelectedItems(i)
Next i
End If
End With
End If
End If
'Proc04_未選択時Empty返却
' --- 未選択 ---
If colPaths.Count = 0 Then
Set_FileDialogFoldersFilesPicker = Empty
Exit Function
End If
'Proc05_コレクションを配列に変換
' --- 配列へ変換 ---
ReDim arrPaths(1 To colPaths.Count)
For i = 1 To colPaths.Count
arrPaths(i) = colPaths(i)
Next i
'Proc06_名前順ソート（バブルソート）
For i = LBound(arrPaths) To UBound(arrPaths) - 1
For j = i + 1 To UBound(arrPaths)
strNameI = Mid(arrPaths(i), InStrRev(arrPaths(i), "\") + 1)
strNameJ = Mid(arrPaths(j), InStrRev(arrPaths(j), "\") + 1)
If StrComp(strNameI, strNameJ, vbTextCompare) > 0 Then
strTemp = arrPaths(i)
arrPaths(i) = arrPaths(j)
arrPaths(j) = strTemp
End If
Next j
Next i
'Proc07_戻り値設定
Set_FileDialogFoldersFilesPicker = arrPaths
End Function
Discussion