iTranslated by AI
The content below is an AI-generated translation. This is an experimental feature, and may contain errors. View original article
😁
VBA Procedure Series T04: Business Improvement VBA for Beginners - Batch Update Disconnected Cells Across Excel Files
About This Article
This article provides the VBA code for a sheet module that allows you to perform bulk edits on consolidated isolated cell values (Value sheet) gathered via A05 and bulk update them back to the original Excel sheets. Simply paste this into a sheet module to use it; no environment setup is required.
Feature Overview:
- [A14] 2-stage workflow for "Aggregate → Edit → Update Original Sheets"
-
Phase 1 (Set): Combines the Mapping sheet and Value sheet to generate the
ReWriteSheetValuetemplate (alternating address rows/value rows). - Manual Edit: The user directly edits cells in the value rows.
- Phase 2 (Execute): Bulk updates the original Excel files with the edited values.
-
Phase 1 (Set): Combines the Mapping sheet and Value sheet to generate the
- Automatically retrieves the original Excel file path from hyperlinks → Opens each file and writes to the target cell.
- Visualizes failed file writes with red markers.
――――――――――――――――――――――――――――――――――
Processing Flow
――――――――――――――――――――――――――――――――――
[A05] CollectExcelSheet
↓ Mapping sheet (Sheet name/Cell address)
↓ Value sheet (Aggregated isolated values)
[A14 Phase 1] sA14_SetReWriteSheetValue
↓ ReWriteSheetValue template (Alternating address/value rows)
[Manual Edit] User edits value rows
↓
[A14 Phase 2] sA14_ExecuteReWriteSheetValue
↓ Bulk updates original Excel sheets
[Completion] Original files are updated with the edited values
――――――――――――――――――――――――――――――――――
*Prerequisite: The Mapping/Value sheets must be prepared in advance using A05_CollectExcelSheet (Article T02).
*The code will be improved incrementally. Detailed usage will be introduced in future articles.
Included Procedures
[Run-type] Procedures assigned to buttons
Run_A14_ReWriteSheetValue Branches between Set/Execute via Phase selection InputBox
Run_sA14_SetReWriteSheetValue Executes Phase 1 template creation only
Run_sA14_ExecuteReWriteSheetValue Executes Phase 2 write operation only
[A14] Bulk update of isolated cells
A14_ReWriteSheetValue Main procedure (Phase dispatcher)
sA14_SetReWriteSheetValue Phase 1: Mapping x Value → ReWriteSheetValue template creation
sA14_ExecuteReWriteSheetValue Phase 2: Writes edited values back to original Excel files
sA14_EnsureSheet Retrieves a sheet by name (creates if not exists)
sA14_CopyHyperlink Copies a cell's hyperlink to another cell
sA14_GetHyperlinkAddress Retrieves a file path from a cell's hyperlink
lngWriteCountForFile Counts the number of writes per file
sA14_MarkFailedFile Applies red markers to failed file rows
[Set-type] Independent functions (shared across multiple procedures)
Set_DesktopPath Retrieves the desktop path
Set_FolderName Extracts folder name from path
Set_FileDialogFolderPicker Selects one folder
Set_FileDialogFolderPickers Selects multiple folders
Set_FileDialogFoldersFilesPicker Selects multiple folders + files
Set_SheetDefaultFormat Applies uniform sheet formatting (font/alignment)
Set_ColorPalette ★Bulk setting for shared color palette for all A-series procedures
Set_DefaultFormatVars Sets default format variable values for sheets
Naming Conventions and Definitions
Run_ : Procedure assigned to a button (Initializes + Calls main procedure)
Axx_ : Main A-series procedure (2-digit number)
sAxx_ : Sub-procedure for each main procedure
Set_ : Independent function shared across multiple procedures
m_ : Module-level Private variable
CST_ : Local Const constant
ProcXX : Code location within a procedure (common language for fixes/reviews)
str/lng/bln/obj/ws/dbl : Prefix indicating variable type
Orthodox Processing:
Orthodox Processing refers to an indispensable series of sub-procedures executed in sequence to achieve the main procedure's goal.
If each step succeeds (True), it proceeds to the next step, ensuring the main flow runs straight through.
Branch Processing:
Branch Processing refers to conditional/selective sub-procedures that branch off from the main flow.
Execution is determined by user selection (InputBox/MsgBox), error fallbacks when orthodox processing fails (False), or by the boolean value of setting flags. If conditions aren't met, they are skipped. The main procedure's purpose can still be achieved without them, as they serve as auxiliary, secondary, or recovery functions attached to the main flow.
[A14 2-Stage Workflow]
Phase 1: sA14_SetReWriteSheetValue Template Creation (Mapping × Value → ReWriteSheetValue)
Alternating arrangement: Address rows (blue tones) / Value rows (yellow tones)
Phase 2: sA14_ExecuteReWriteSheetValue Write Execution (Edited values → Original Excel)
Failed files are visualized with red markers
[Analogy of Data Structure]
Noodles (Value) : Batch read/write using Cells.Value array
Soup (NumberFormat) : Individual read/write (format information)
→ "Double array pattern" handling values and formats as separate arrays
→ Consistent design philosophy from A05
Usage
■ Prerequisites (Must be executed in advance)
STEP 0 Execute A05_CollectExcelSheet (Article T02)
→ Prepare Mapping sheet (register sheet name and cell address)
→ Prepare Value sheet (isolated values already aggregated)
■ When using A14 Bulk Write-back
STEP 1 Open Excel VBA editor (Alt+F11)
STEP 2 Paste the code into a sheet module (e.g., Sheet1)
STEP 3 Execute Run_A14_ReWriteSheetValue
→ Phase selection InputBox appears
→ Input "1": Phase 1 (Template creation)
STEP 4 ReWriteSheetValue sheet is automatically generated
(Address/value rows are alternating and color-coded)
STEP 5 User edits value row cells directly
→ Overwrite only the values you want to change
STEP 6 Execute Run_A14_ReWriteSheetValue again
→ Input "2": Phase 2 (Write execution)
→ Bulk write-back to original Excel files
→ Failed files displayed with red markers
■ Standalone execution (For advanced users)
Run_sA14_SetReWriteSheetValue Execute Phase 1 only
Run_sA14_ExecuteReWriteSheetValue Execute Phase 2 only
Full Code
Option Explicit
' ===========================================================================
' | ZENN Blog Article 3 - Bulk Write-back of Isolated Cells (A14: ReWriteSheetValue)
' | File: ZENN_Article_3_VBA0+A14_BulkWriteBack.cls
' | Created: 20260506
' | Ver.0105 [20260506] Function No.01 / Update No.05
' | Content: VBA0(Common) + A14: Bulk write-back of isolated cells (A05 Value → Original Excel)
' | Usage: Simply paste into a sheet module
' | Prerequisite: Mapping/Value sheets prepared via A05_CollectExcelSheet
' ===========================================================================
' === A14 Ver. Change History ===============================================
' Ver.0100 [20260506] First edition (Mapping × Value → ReWriteSheetValue generation)
' Ver.0101 [20260506] Layout revision (Alternating address rows + input rows)
' Ver.0102 [20260506] Input row Value existing value preset (A05 double array pattern)
' Ver.0103 [20260506] Measures against remaining merge on Proc06 re-execution (Added Cells.UnMerge)
' Ver.0104 [20260506] Measures against Proc08-4 C+ empty field symptoms (Changed to per-cell write)
' Ver.0105 [20260506] Removed Debug.Print debug code (Clean up)
' ===========================================================================
Private m_lngColorDepth1 As Long ' Background color indicating main folder (depth 1)
Private m_lngColorDepth2 As Long ' Background color indicating sub-folder (depth 2)
Private m_lngColorDepth3 As Long ' Background color indicating sub-sub-folder (depth 3)
Private m_lngColorDepth4 As Long ' Sub-sub-sub and below (depth 4+)
Private m_blnShowScreen As Boolean ' VBA execution screen display (True=Show/False=Suppress)
Private m_strPrefixCode As String ' File name prefix at A04_copy
Private m_lngColorHeader As Long ' Header background color
Private m_blnAdvancedPicker As Boolean ' Advanced multiple folder and file selection (False=Single/True=Multiple)
'Used in A01_ListFiles initialization. False (initial value) selects by folder unit, True enables selecting multiple folders and files.
'--------------------------------------------
Private m_lngInteriorColorDeduplication1 As Long ' Deduplication_Background color: Cell background when no duplicates
Private m_lngInteriorColorDeduplication2 As Long ' Deduplication_Background color: Cell background for 2 duplicates
Private m_lngInteriorColorDeduplication3 As Long ' Deduplication_Background color: Cell background for 3-5 duplicates
Private m_lngInteriorColorDeduplication4 As Long ' Deduplication_Background color: Cell background for 6+ duplicates
Private m_lngFontColorDeduplication1 As Long ' Deduplication_Font color: Font color when no duplicates
Private m_lngFontColorDeduplication2 As Long ' Deduplication_Font color: Font color for 2 duplicates
Private m_lngFontColorDeduplication3 As Long ' Deduplication_Font color: Font color for 3-5 duplicates
Private m_lngFontColorDeduplication4 As Long ' Deduplication_Font color: Font color for 6+ duplicates
'--------------------------------------------
Private m_lngA05ColorMappingHeader As Long ' A05 Mapping template_Header background color (light yellow)
Private m_lngA05ColorMappingSample As Long ' A05 Mapping template_Sample row background color (light blue)
Private m_lngA05ColorMappingSheetName As Long ' A05 Mapping template_Sheet name column font color (red)
Private m_lngA05ColorMappingBorder As Long ' A05 Mapping template_Border color (gray)
Private m_lngA05ColorMappingHelp As Long ' A05 Mapping template_Help background color (light beige)
Private m_lngA05ColorValueHeader As Long ' A05 Value sheet_Header background color (light yellow)
'--------------------------------------------
Private m_lngA07ColorFileRow As Long ' A07 Sheet management_Row1 file name row background color (light blue)
Private m_lngA07ColorLabel As Long ' A07 Sheet management_Column A label (current/new) background color (light yellow)
Private m_lngA07ColorAfterCell As Long ' A07 Sheet management_Row3 "New" input field background color (light beige)
Private m_lngA07ColorChanged As Long ' A08 Rename success cell background color (light green)
Private m_lngA07ColorError As Long ' A08 Error indication (cannot open/duplicates) color (light red)
'--------------------------------------------
' === A01 Column H "MD Exists" exclusion (file row) format ===
' [Added:20260429] Format for non-folder (file row) exclusion display
Private m_strA01MdCheckOutOfScope As String ' Exclusion display character ("―" full-width dash)
Private m_lngA01MdCheckOutOfScopeFontColor As Long ' Exclusion font color (gray 25% RGB(191,191,191))
Private m_lngA01MdCheckOutOfScopeAlign As Long ' Exclusion alignment (xlRight)
'--------------------------------------------
' === Sheet Common Default Format ============================================
' Common appearance settings referenced by every A-series procedure
' Bulk applied to entire sheet via Set_SheetDefaultFormat(ws)
Private m_strDefaultFontName As String ' Sheet common: Font name (e.g., "Century")
Private m_lngDefaultFontSize As Long ' Sheet common: Font size (e.g., 14)
Private m_lngDefaultVAlign As Long ' Sheet common: Vertical alignment (xlCenter etc.)
Private m_lngDefaultHAlign As Long ' Sheet common: Horizontal alignment (xlCenter etc.)
'--------------------------------------------
' === Sheet Common Color Palette (Sequential Presets) ============================
' Assign usage by number in Run_ procedures
' Example: m_FontColor01 = Input field font color, m_BgColor01 = Header background, etc.
' 4-color preset (expandable as needed)
Private m_FontColor01 As Long ' Font color 01
Private m_FontColor02 As Long ' Font color 02
Private m_FontColor03 As Long ' Font color 03
Private m_FontColor04 As Long ' Font color 04
Private m_BgColor01 As Long ' Background color 01
Private m_BgColor02 As Long ' Background color 02
Private m_BgColor03 As Long ' Background color 03
Private m_BgColor04 As Long ' Background color 04
'--------------------------------------------
' === Sheet Management 5-Mode Dedicated Colors + Pulldown Text [Added:20260503] ====
' Fully synced with HTML prototype (sheet_management_5_modes_prototype.html)
' Op 1-1: Change sheet name Green (Safe write)
' Op 1-2: Delete sheet name Red (Dangerous operation)
' Op 1-3: Aggregate sheet name Orange (Extract)
' Op 2-1: Value format Purple (Fix conversion)
' Op 2-2: Reset sheet format Teal (Structure change, 4-process integration)
Private m_strMode1_1_Placeholder As String ' "/Input new sheet name/" Op 1-1 initial pre-fill
Private m_strMode1_2_YesText As String ' "Yes(Delete)"
Private m_strMode1_3_YesText As String ' "Yes(Aggregate target)"
Private m_strMode2_1_YesText As String ' "Yes(Fix value)"
Private m_strMode2_2_YesText As String ' "Yes(Reset format)" [Spec change:20260503]
Private m_lngMode1_1_Bg As Long ' 1-1 Background (Green)
Private m_lngMode1_1_Font As Long ' 1-1 Font
Private m_lngMode1_2_Bg As Long ' 1-2 Background (Red)
Private m_lngMode1_2_Font As Long ' 1-2 Font
Private m_lngMode1_3_Bg As Long ' 1-3 Background (Orange)
Private m_lngMode1_3_Font As Long ' 1-3 Font
Private m_lngMode2_1_Bg As Long ' 2-1 Background (Purple)
Private m_lngMode2_1_Font As Long ' 2-1 Font
Private m_lngMode2_2_Bg As Long ' 2-2 Background (Teal)
Private m_lngMode2_2_Font As Long ' 2-2 Font
'--------------------------------------------
' === A12 Sheet format reset 4 flags [Added:20260503] [Const:20260503] ===
' Declared as module-level constants + fixed with one-line initial values (no dynamic changes)
' ★Toggle behavior by directly editing these True/False flags★
' Run_A12_ResetSheetFormat requires no initialization, referenced directly in A12_ResetSheetFormat body
Private Const CST_blnA12_Unmerge As Boolean = True ' (1) Clear merge (Cells.UnMerge)
Private Const CST_blnA12_ClearBgColor As Boolean = True ' (2) Clear background (ColorIndex=xlNone)
Private Const CST_blnA12_ResetFontColor As Boolean = True ' (3) Black font (Font.Color=RGB(0,0,0))
Private Const CST_blnA12_UnfreezePanes As Boolean = True ' (4) Unfreeze panes (FreezePanes=False)
'--------------------------------------------
' === A05 Value sheet empty row deletion required input count [Added:20260503] ===
' Declared as module-level constant + fixed with one-line initial value
' For each row in Value sheet starting from Column C (CntColNum),
' If input cells < CST_lngA05_KeepRowNum, delete the row
' ★Toggle threshold by directly editing this number★
Private Const CST_lngA05_KeepRowNum As Long = 2 ' Required input count (default 2, less is considered empty/deleted)
'--------------------------------------------
' === A06 Arithmetic expansion group alternating background [Added:20260503] ===
' Declared as module-level constant + fixed with one-line initial value
' 1st group (odd) = xlNone / 2nd group (even) = CST_lngA06_AlternateBg (light yellow)
' Emphasis on group boundaries with stripes for visibility
Private Const CST_lngA06_AlternateBg As Long = 14809343 ' RGB(255, 248, 225) Light yellow (Even group background)
'--------------------------------------------
' =============================================================
' | A14 Procedure Group: Mapping × Value Bulk Write-back
' =============================================================
' ────────────────────────────────────────────────────────────
' ■ Execution Procedures Run-series (A14 main + Phase-specific standalone)
' ────────────────────────────────────────────────────────────
' ===================================
' Run_A14_ReWriteSheetValue
' Procedure to execute A14_ReWriteSheetValue
' Select Set or Execute via Phase selection InputBox
' ===================================
' [Updated:20260506]
Public Sub Run_A14_ReWriteSheetValue()
'Proc01_Set color palette (Common to all A-series)
Call Set_ColorPalette
'Proc02_Call main procedure
Me.A14_ReWriteSheetValue
End Sub
' ===================================
' Run_sA14_SetReWriteSheetValue
' Execution procedure for sA14_SetReWriteSheetValue
' Mapping × Value → ReWriteSheetValue template creation
' ===================================
' [Updated:20260506]
Public Sub Run_sA14_SetReWriteSheetValue()
'Proc01_Set color palette
Call Set_ColorPalette
'Proc02_Call main procedure
Me.sA14_SetReWriteSheetValue
End Sub
' ===================================
' Run_sA14_ExecuteReWriteSheetValue
' Execution procedure for sA14_ExecuteReWriteSheetValue
' Bulk updates edited values of ReWriteSheetValue to original Excel sheets
' ===================================
' [Updated:20260506]
Public Sub Run_sA14_ExecuteReWriteSheetValue()
'Proc01_Set color palette
Call Set_ColorPalette
'Proc02_Call main procedure
Me.sA14_ExecuteReWriteSheetValue
End Sub
' ────────────────────────────────────────────────────────────
' ■ A-series Main (A14 main procedure + sA-series sub placed in orthodox processing order)
' ────────────────────────────────────────────────────────────
' ===================================
' A14_ReWriteSheetValue (Ver.0105) (Main procedure)
' Phase selection dispatcher
' Refer to === Ver. Change History === block at file head
' ===================================
' [Updated:20260506]
Sub A14_ReWriteSheetValue()
'2-stage workflow:
' Phase 1=Template creation (Set) / Phase 2 Manual edit / Phase 3=Write execution (Execute)
'Main procedure is a dispatcher that selects Phase 1/3 via InputBox and calls the corresponding sA
Dim strPhase As String
'Proc01_Phase selection InputBox
strPhase = InputBox( _
"A14 ReWriteSheetValue Bulk Write-back" & vbCrLf & vbCrLf & _
"[1] ReWriteSheetValue Template creation (Mapping × Value → Edit template)" & vbCrLf & _
"[2] Execute write to original Excel (Bulk write-back edited values)" & vbCrLf & vbCrLf & _
"Prerequisite: Mapping/Value must be prepared via A05_CollectExcelSheet." & vbCrLf & _
"Enter 1 or 2 (Cancel to exit)", _
"A14 Phase Selection", "1")
'Proc02_Phase-based dispatch
Select Case Trim(strPhase)
Case "1"
Call sA14_SetReWriteSheetValue
Case "2"
Call sA14_ExecuteReWriteSheetValue
Case ""
Exit Sub ' Cancel
Case Else
MsgBox "Please enter 1 or 2.", vbExclamation, "A14 Phase Selection"
End Select
End Sub
────────────────────────────────────────────────────────────
' ■ Orthodox Processing: Phase 1 Template Creation (Mapping × Value → ReWriteSheetValue)
' ────────────────────────────────────────────────────────────
' ===================================
' sA14_SetReWriteSheetValue
' Cross-references the Mapping sheet and Value sheet to create
' a template for the ReWriteSheetValue sheet.
' - For each row in Value, inserts the corresponding Mapping row (cell address) immediately before it.
' - Result: Alternating arrangement of Address rows / Value rows / Address rows / Value rows …
' ===================================
' [Updated:20260506]
Sub sA14_SetReWriteSheetValue()
' Local constants
Const CST_SHEET_MAPPING As String = "Mapping"
Const CST_SHEET_VALUE As String = "Value"
Const CST_SHEET_REWRITE As String = "ReWriteSheetValue"
' [Removed:20260506] CST_ADDR_ROW_MARKER ─ Changed to identifying address rows by filename (link)
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: Current slot 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 ' [Added:20260506] Noodles=Value array (COM bulk read)
Dim arrRowFormats() As String ' [Added:20260506] Soup=NumberFormat array (individual read)
Dim lngRowWidth As Long ' [Added:20260506] Column count per row
'Proc00_Performance settings
On Error GoTo ErrHandler
lngOldCalc = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False
'Proc01_Mapping sheet existence check
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 sheet not found." & vbCrLf & _
"Please execute A05_CollectExcelSheet first.", _
vbExclamation, "A14 Set Phase1"
GoTo Cleanup
End If
'Proc02_Value sheet existence check
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 sheet not found." & vbCrLf & _
"Please execute A05_CollectExcelSheet first.", _
vbExclamation, "A14 Set Phase1"
GoTo Cleanup
End If
'Proc03_Mapping last column/row
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 "No data in Mapping (Sheet name + cell position in row 2 or later is required).", _
vbExclamation, "A14 Set Phase1"
GoTo Cleanup
End If
'Proc04_Value last row
lngLastRowV = wsValue.Cells(wsValue.Rows.Count, 1).End(xlUp).Row
If lngLastRowV < 2 Then
MsgBox "No data in Value. Please execute A05_CollectExcelSheet first.", _
vbExclamation, "A14 Set Phase1"
GoTo Cleanup
End If
'Proc05_Convert Mapping to dictionary (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
' Construct address array (Col B onwards)
ReDim arrAddresses(1 To lngLastColM - 1)
For j = 2 To lngLastColM
arrAddresses(j - 1) = CStr(wsMapping.Cells(r, j).Value)
Next j
' Give each SheetName a 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_Secure and clear ReWriteSheetValue
' ★[Revised:20260506-3] Completely clear previous merges before writing values/formats
' Since remnants from the previous run cause A+B merge malfunctions in Proc08-4,
' fully initialize via UnMerge → Clear
Set wsReWrite = sA14_EnsureSheet(CST_SHEET_REWRITE)
On Error Resume Next
wsReWrite.Cells.UnMerge
On Error GoTo ErrHandler
wsReWrite.Cells.Clear
'Proc07_Copy header row (Use Value header as is)
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_Traverse each Value row for alternating arrangement
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_Get slot Index per (file, sheet)
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_Get corresponding Mapping slot
If Not dictMap.Exists(strSheetName) Then GoTo NextValRow
Set colSlots = dictMap(strSheetName)
If lngSlotIndex < 1 Or lngSlotIndex > colSlots.Count Then
' Exceeded Mapping rows → no slot (can occur due to file switching, etc.)
' Cycle through existing slot counts (modulo)
lngSlotIndex = ((lngSlotIndex - 1) Mod colSlots.Count) + 1
dictCounter(strKey) = lngSlotIndex
End If
Set dictSlot = colSlots(lngSlotIndex)
arrAddresses = dictSlot("Addresses")
'Proc08-3_Output address row (A05 pattern: Array 1=Batch write values, Array 2=Individual write formats)
' ★[Spec change:20260506] Address row=Greenish background, file name link placed in Col A
' ★[A05 Consistency:20260506] Array 1 (Values)= [FileName, SheetName, addr1, addr2…] bulk write
' Array 2 (Formats)= All cells "@" (String fixed) individual write
lngRowWidth = lngLastColM + 1
' Construct Array 1 (Noodles=Values)
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
' Construct Array 2 (Soup=Formats): Address row cells all string fixed
ReDim arrRowFormats(1 To lngRowWidth)
For j = 1 To lngRowWidth
arrRowFormats(j) = "@"
Next j
' Bulk write Array 1 (Values) to Range (1 COM call)
wsReWrite.Range(wsReWrite.Cells(lngOutRow, 1), _
wsReWrite.Cells(lngOutRow, lngRowWidth)).Value = arrRowValues
' Set Array 2 (Formats) individually per cell (NumberFormat cannot be array-assigned)
For j = 1 To lngRowWidth
wsReWrite.Cells(lngOutRow, j).NumberFormat = arrRowFormats(j)
Next j
' Hyperlink Col A (Reproduce file name link from Value)
Call sA14_CopyHyperlink(wsValue, r, wsReWrite, lngOutRow)
With wsReWrite.Range(wsReWrite.Cells(lngOutRow, 1), _
wsReWrite.Cells(lngOutRow, lngRowWidth))
.Interior.Color = m_BgColor04 ' Pale green: Address row (not for editing)
.Font.Italic = False
.Font.Color = RGB(0, 0, 0) ' Black
End With
' Col C+ (cell address part) has lighter font color + italics to visualize "non-editable"
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_Input row for updated values (A05 pattern: Array 1=Existing Value, Array 2=Original Value format)
' ★[Spec change:20260506-2] Preset existing Value in C+ (Method where user overwrites)
' ★[A05 Consistency:20260506] Array 1 (Values)= Bulk write Value C+
' Array 2 (Formats)= Individual write Value NumberFormat
' - Join A+B horizontally and display "Updated Value" label centered
' - Col C onwards is pre-filled with values from Value sheet row
' - User edits only necessary cells → Reflect to original Excel in Phase 3
' - No background (white) for high visibility while editing
' Label display by merging A+B
With wsReWrite.Range(wsReWrite.Cells(lngOutRow, 1), _
wsReWrite.Cells(lngOutRow, 2))
.Merge
.Value = "Updated Value"
.HorizontalAlignment = xlCenter
.VerticalAlignment = xlCenter
.Font.Italic = False
.Font.Color = RGB(120, 120, 120) ' Gray: Label-like
.Interior.ColorIndex = xlNone ' No background
End With
' Construct Array 1 (Noodles=Values): Get C+ values from Value sheet
' Construct Array 2 (Soup=Formats): NumberFormat of C+ from Value sheet
' *C+ column count = lngRowWidth - 2 (excluding 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
' ★[Revised:Ver.0104:20260506] Change to per-cell loop write to handle cases where bulk write fails
' (Root cause fix for C+ values becoming blank symptoms)
' ★[Ver.0105:20260506] Debug.Print debug code removed
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+ Input area visualization (White background)
With wsReWrite.Range(wsReWrite.Cells(lngOutRow, 3), _
wsReWrite.Cells(lngOutRow, lngRowWidth))
.Interior.ColorIndex = xlNone
End With
lngOutRow = lngOutRow + 1
NextValRow:
Next r
'Proc09_Borders
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_AutoFit column width
wsReWrite.Columns("A:Z").AutoFit
'Proc11_Completion notice
MsgBox "ReWriteSheetValue template created." & vbCrLf & vbCrLf & _
"Output row count: " & (lngOutRow - 1) & " rows" & vbCrLf & _
"(Alternating Address rows (pale green) + Input rows (white))" & vbCrLf & vbCrLf & _
"Next steps:" & vbCrLf & _
" 1. Input rows (white) Col C onwards are pre-filled with Value sheet existing values" & vbCrLf & _
" Edit only necessary cells (formats inherited)" & vbCrLf & _
" ★Blanked cells = Skip write-back = Keep original Excel value" & vbCrLf & _
" 2. After editing, execute Run_sA14_ExecuteReWriteSheetValue" & vbCrLf & _
" 3. Bulk write-back to original Excel files", _
vbInformation, "A14 Phase1 Completed"
GoTo Cleanup
ErrHandler:
MsgBox "Error: " & Err.Number & " - " & Err.Description, vbCritical, "A14 Set Phase1"
Cleanup:
Application.ScreenUpdating = True
Application.Calculation = lngOldCalc
Application.EnableEvents = True
Application.DisplayAlerts = True
End Sub
────────────────────────────────────────────────────────────
' ■ Orthodox Processing: Phase 3 Write Execution (ReWriteSheetValue → Original Excel)
' ────────────────────────────────────────────────────────────
' ===================================
' sA14_ExecuteReWriteSheetValue
' Bulk update edited values from ReWriteSheetValue to the corresponding original Excel file sheets
' - Get file path from Hyperlink in Col A of value rows
' - Get target cell address from the address row immediately above
' - Sheet name is in Col B
' - Open each Excel file, write to specified cell → Save → Close
' ===================================
' [Updated:20260506]
Sub sA14_ExecuteReWriteSheetValue()
' Local constants
Const CST_SHEET_REWRITE As String = "ReWriteSheetValue"
' [Removed:20260506] CST_ADDR_ROW_MARKER ─ Changed to identifying address rows by filename (link)
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_Start time
dblStartTime = Timer
'Proc00-1_Performance settings
On Error GoTo ErrHandler
lngOldCalc = Application.Calculation
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual
Application.EnableEvents = False
Application.DisplayAlerts = False
'Proc01_Check for ReWriteSheetValue sheet
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 sheet not found." & vbCrLf & _
"Please execute Run_sA14_SetReWriteSheetValue first.", _
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 "No data in ReWriteSheetValue.", _
vbExclamation, "A14 Execute Phase3"
GoTo Cleanup
End If
'Proc02_Execution confirmation MsgBox
lngAnswer = MsgBox( _
"Bulk write back edited values from ReWriteSheetValue to original Excel files." & vbCrLf & vbCrLf & _
"Execution rows: Approx " & ((lngLastRow - 1) \ 2) & " items (Value rows)" & vbCrLf & vbCrLf & _
"★This operation modifies original files. Backups are recommended." & vbCrLf & vbCrLf & _
"Execute?", _
vbYesNo + vbExclamation, "A14 Execute Execution Confirmation")
If lngAnswer <> vbYes Then GoTo Cleanup
'Proc03_Aggregate write tasks by file (Open file once, perform all writes)
' ★[Spec change:20260506] Support for new layout
' - Address row: Hyperlink in Col A (=file path), Col B=Sheet, Col C+=Cell address
' - Input row: A+B merged "Updated Value", Col C+=User-input new value
' - If Col C onwards is blank, original Excel is not overwritten (skipped)
Set dictByFile = CreateObject("Scripting.Dictionary")
r = 2
Do While r <= lngLastRow
' Check if address row (Hyperlink in Col A)
strFilePath = sA14_GetHyperlinkAddress(wsReWrite.Cells(r, 1))
If strFilePath = "" Then
' No hyperlink → Not address row (Input row or blank row) → Next row
r = r + 1
GoTo NextScanRow
End If
' Address row: Get SheetName and cell address array
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
' Input row immediately after: Get new value array (Col C onwards)
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
' Write task = (SheetName, Addr, NewValue) aggregated per 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 input value is blank, skip write (do not overwrite original Excel)
If IsEmpty(arrNewValues(j)) Or Trim(CStr(arrNewValues(j))) = "" Then
' Skip: Keep original values where user did not input
Else
Set dictWrite = CreateObject("Scripting.Dictionary")
dictWrite("SheetName") = strSheetName
dictWrite("Address") = arrAddresses(j)
dictWrite("Value") = arrNewValues(j)
dictWrite("RowInRW") = r + 1 ' Row in ReWriteSheetValue (for feedback display)
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 "No write targets found.", vbInformation, "A14 Execute Phase3"
GoTo Cleanup
End If
'Proc04_Loop through files and write
lngFileIndex = 0
lngWriteCount = 0
lngFailCount = 0
lngOpenFailed = 0
For Each varKey In dictByFile.Keys
lngFileIndex = lngFileIndex + 1
strFilePath = CStr(varKey)
Set colWrites = dictByFile(strFilePath)
' Update status bar
Application.StatusBar = "A14 writing back... [" & lngFileIndex & "/" & lngTotalFiles & "] " & _
CreateObject("Scripting.FileSystemObject").GetFileName(strFilePath)
DoEvents
'Proc04-1_Open file (Write mode)
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)
' Record error
Call sA14_MarkFailedFile(wsReWrite, colWrites, "### Cannot open")
GoTo NextFile
End If
Err.Clear
On Error GoTo ErrHandler
'Proc04-2_Execute each write task
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 "Sheet missing: " & 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 ' Success: Keep pale green
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_Save and close
On Error Resume Next
wbSrc.Save
wbSrc.Close SaveChanges:=False
Err.Clear
On Error GoTo ErrHandler
NextFile:
Next varKey
Application.StatusBar = False
'Proc05_Elapsed time
dblElapsed = Timer - dblStartTime
If dblElapsed < 0 Then dblElapsed = dblElapsed + 86400
'Proc06_Completion notice
strReport = "Write-back completed:" & vbCrLf & _
" Target files: " & lngTotalFiles & " items" & vbCrLf & _
" Successful cells: " & lngWriteCount & " items" & vbCrLf & _
" Failed cells: " & lngFailCount & " items" & vbCrLf
If lngOpenFailed > 0 Then
strReport = strReport & " Failures due to unopenable files: " & lngOpenFailed & " items" & vbCrLf
End If
strReport = strReport & " Processing time: " & Format(dblElapsed, "0.000") & " seconds"
MsgBox strReport, vbInformation, "A14 Phase3 Completed"
GoTo Cleanup
ErrHandler:
Application.StatusBar = False
MsgBox "Error: " & 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
' ────────────────────────────────────────────────────────────
' ■ Common Subprocedures (A14 Internal Helpers)
' ────────────────────────────────────────────────────────────
' ===================================
' sA14_EnsureSheet
' Get sheet with specified name, create at the end if it does not exist
' * Same logic as A05 sA05_EnsureSheet (independent implementation for cohesion)
' ===================================
' [Updated:20260506]
Private Function sA14_EnsureSheet(strName As String) As Worksheet
Dim ws As Worksheet
'Proc01_Search for existing sheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(strName)
On Error GoTo 0
'Proc02_Create new at the end if it does not exist
If ws Is Nothing Then
Set ws = ThisWorkbook.Worksheets.Add( _
After:=ThisWorkbook.Worksheets(ThisWorkbook.Worksheets.Count))
ws.Name = strName
End If
'Proc03_Set return value
Set sA14_EnsureSheet = ws
End Function
' ===================================
' sA14_CopyHyperlink
' Copy hyperlink from Value sheet filename cell (Col A) to ReWrite
' ===================================
' [Updated: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_Check if source cell has a hyperlink
If wsSrc.Cells(lngSrcRow, 1).Hyperlinks.Count = 0 Then Exit Sub
'Proc02_Get hyperlink information
Set hl = wsSrc.Cells(lngSrcRow, 1).Hyperlinks(1)
strAddr = hl.Address
strDisplay = CStr(wsSrc.Cells(lngSrcRow, 1).Value)
'Proc03_Delete existing link & recreate
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
' Get address (file path) from cell hyperlink
' Returns "" if not found
' ===================================
' [Updated:20260506]
Private Function sA14_GetHyperlinkAddress(rng As Range) As String
'Proc01_Check hyperlink existence
If rng.Hyperlinks.Count = 0 Then
sA14_GetHyperlinkAddress = ""
Exit Function
End If
'Proc02_Get address
sA14_GetHyperlinkAddress = rng.Hyperlinks(1).Address
End Function
' ===================================
' lngWriteCountForFile
' Returns the number of elements in a Collection as Long (Simple helper)
' ===================================
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
' If a file could not be opened, turn the value cells of all its write tasks light red
' ===================================
' [Updated:20260506]
Private Sub sA14_MarkFailedFile(wsReWrite As Worksheet, _
colWrites As Collection, _
strReason As String)
Dim varW As Variant
Dim dictW As Object
'Proc01_Mark all tasks with error
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 Group: Independent Functions (Shared by multiple procedures)
' =============================================================
' ===================================
' Set_DesktopPath
' Set_ procedures are independent functions accessible from various procedures
' Returns the desktop path
' Return value: Absolute desktop path
' ===================================
' [Updated:20260428]
Function Set_DesktopPath() As String
'Proc01_Get desktop path via WScript.Shell
Dim objShell As Object
Set objShell = CreateObject("WScript.Shell")
Set_DesktopPath = objShell.SpecialFolders("Desktop")
Set objShell = Nothing
End Function
' ===================================
' Set_FileDialogFolderPickers
' Opens dialog, allows selecting multiple folders, returns path list
' Takes arguments from caller for title and button label
' strTitle Dialog title
' strPrompt Button label
' Return value: Array of selected folder paths (Empty if canceled)
' ===================================
' [Updated: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_Initialize dialog
Set objDialog = Application.FileDialog(msoFileDialogFolderPicker)
'Proc02_Select multiple folders
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 return value
Set_FileDialogFolderPickers = strPaths
Set objDialog = Nothing
End Function
' ===================================
' Set_FolderName
' Independent function to get folder name from folder path
' Arg: strFolderPath Full folder path
' Return value: Folder name only
' ===================================
' [Updated:20260428]
Function Set_FolderName(strFolderPath As String) As String
'Proc01_Extract folder name via FSO
Dim objFileSystemObject As Object
Set objFileSystemObject = CreateObject("Scripting.FileSystemObject")
Set_FolderName = objFileSystemObject.GetFolder(strFolderPath).Name
Set objFileSystemObject = Nothing
End Function
' ===================================
' Set_SheetDefaultFormat
' Applies sheet default formatting (font, size, alignment) in bulk
' Refers to variables initialized in Run_ procedures
' m_strDefaultFontName / m_lngDefaultFontSize
' m_lngDefaultVAlign / m_lngDefaultHAlign
' [Modified:20260503] Added uninitialized fallback to prevent Runtime Error 1004
' Arg: ws Worksheet to apply format to
' ===================================
' [Updated:20260503]
Sub Set_SheetDefaultFormat(ws As Worksheet)
'Proc01_Uninitialized fallback [Added:20260503]
' Prevent Runtime Error 1004 occurring if ws.Cells.Font.Size is set without initialization
If m_strDefaultFontName = "" Or m_lngDefaultFontSize <= 0 Then
Call Set_DefaultFormatVars
End If
'Proc02_Bulk apply to all cells (Safety with error handler)
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
' ★Bulk set color palette shared by all A-series procedures★
' Editing this one spot synchronizes colors across A01/A05/A07/A08.
'
' Structure:
' ① Numbered Presets (Common pool) m_FontColor01–04 / m_BgColor01–04
' ② A-series Named Colors (Aliased to numbered presets where possible)
' - A01 Hierarchy colors / Deduplication colors
' - A05 Mapping/Value colors
' - A07/A08 Sheet management colors
' - Sheet management 5-mode colors [Added:20260503]
' ===================================
' [Updated:20260503]
Sub Set_ColorPalette()
'===========================================================
' [Common Pool] Color Palette Numbered Presets
'===========================================================
'Proc01_Font Colors 01–04
m_FontColor01 = RGB( 24, 92, 55) ' Green: Input field/Editing text color
m_FontColor02 = RGB( 0, 0, 0) ' Black: Standard text color
m_FontColor03 = RGB(192, 0, 0) ' Dark Red: Warning/Error text color
m_FontColor04 = RGB(255, 255, 255) ' White: Inverted text on dark background
'Proc02_Background Colors 01–04
m_BgColor01 = RGB(217, 236, 255) ' Pale Blue: Header/Filename row
m_BgColor02 = RGB(255, 248, 225) ' Pale Yellow: Label/Heading
m_BgColor03 = RGB(255, 251, 229) ' Pale Beige: Input field/Auxiliary
m_BgColor04 = RGB(212, 244, 221) ' Pale Green: Success/Normal
'===========================================================
' [A-series Named Colors] Backward compatibility synced to new palette
'===========================================================
'Proc03_A01 Hierarchy Colors (Yellow quartiles)
m_lngColorDepth1 = RGB(255, 192, 0) ' 100% Main
m_lngColorDepth2 = RGB(255, 213, 64) ' 75% Sub
m_lngColorDepth3 = RGB(255, 234, 128) ' 50% Sub-sub
m_lngColorDepth4 = RGB(255, 255, 192) ' 25% Sub-sub-sub or below
m_lngColorHeader = RGB(255, 255, 153) ' Header BG
'Proc04_A01 Deduplication Colors (Red quartiles)
m_lngInteriorColorDeduplication1 = RGB(255, 255, 255) ' No duplicate: White
m_lngInteriorColorDeduplication2 = RGB(255, 220, 220) ' 2 duplicates: Pale Red
m_lngInteriorColorDeduplication3 = RGB(255, 150, 150) ' 3–5 duplicates: Medium Red
m_lngInteriorColorDeduplication4 = RGB(192, 0, 0) ' 6+ duplicates: Dark Red
m_lngFontColorDeduplication1 = m_FontColor02 ' Black
m_lngFontColorDeduplication2 = m_FontColor02 ' Black
m_lngFontColorDeduplication3 = m_FontColor02 ' Black
m_lngFontColorDeduplication4 = m_FontColor04 ' White
'Proc05_A05 Mapping/Value Colors
m_lngA05ColorMappingHeader = RGB(255, 255, 153) ' Pale Yellow: Header
m_lngA05ColorMappingSample = RGB(230, 243, 255) ' Pale Blue: Sample row
m_lngA05ColorMappingSheetName = RGB(211, 47, 47) ' Red: Sheet name col text
m_lngA05ColorMappingBorder = RGB(150, 150, 150) ' Gray: Border
m_lngA05ColorMappingHelp = RGB(255, 243, 205) ' Pale Beige: Help background
m_lngA05ColorValueHeader = RGB(255, 255, 153) ' Pale Yellow: Value sheet header
'Proc06_A07/A08 Sheet Management Colors (Aliased to numbered presets)
m_lngA07ColorFileRow = m_BgColor01 ' Pale Blue: Row 1 filename
m_lngA07ColorLabel = m_BgColor02 ' Pale Yellow: Col A label
m_lngA07ColorAfterCell = m_BgColor03 ' Pale Beige: Row 3 edit input
m_lngA07ColorChanged = m_BgColor04 ' Pale Green: Success
m_lngA07ColorError = RGB(255, 220, 220) ' Pale Red: Error
'Proc07_A01 Col H "MD check" Exclusion format [Added:20260429]
m_strA01MdCheckOutOfScope = "―" ' Full-width dash
m_lngA01MdCheckOutOfScopeFontColor = RGB(191, 191, 191) ' Gray 25%
m_lngA01MdCheckOutOfScopeAlign = xlRight ' Right-align
'Proc08_Sheet Management 5-mode Colors [Added:20260503]
m_strMode1_1_Placeholder = "/Enter New Sheet Name/"
m_strMode1_2_YesText = "Yes(Delete)"
m_strMode1_3_YesText = "Yes(Aggregate)"
m_strMode2_1_YesText = "Yes(Fix Value)"
m_strMode2_2_YesText = "Yes(Reset Format)"
m_lngMode1_1_Bg = RGB(232, 245, 233) ' 1-1 Green (Safe)
m_lngMode1_1_Font = RGB( 27, 94, 32)
m_lngMode1_2_Bg = RGB(255, 235, 238) ' 1-2 Red (Dangerous)
m_lngMode1_2_Font = RGB(183, 28, 28)
m_lngMode1_3_Bg = RGB(255, 243, 224) ' 1-3 Orange (Extract)
m_lngMode1_3_Font = RGB(230, 81, 0)
m_lngMode2_1_Bg = RGB(243, 229, 245) ' 2-1 Purple (Fix Value)
m_lngMode2_1_Font = RGB( 74, 20, 140)
m_lngMode2_2_Bg = RGB(224, 242, 241) ' 2-2 Turquoise (Structure Change)
m_lngMode2_2_Font = RGB( 0, 77, 64)
End Sub
' ===================================
' Set_DefaultFormatVars
' ★Bulk set default format variables shared by A-series procedures★
' Applicable to all sheets by calling at the start of Run_ procedures.
' ===================================
' [Updated:20260428]
Sub Set_DefaultFormatVars()
'Proc01_Set common default values
m_strDefaultFontName = "Century"
m_lngDefaultFontSize = 14
m_lngDefaultVAlign = xlCenter
m_lngDefaultHAlign = xlCenter
End Sub
' ===================================
' [Updated:20260428]
Function Set_FileDialogFolderPicker(strTitle As String, _
strPrompt As String) As String
Dim strFolderPath As String
'Proc01_Display folder pick dialog
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 return value
Set_FileDialogFolderPicker = strFolderPath
End Function
' ===================================
' Set_FileDialogFoldersFilesPicker
' Handles multiple folder/file selections
' ===================================
' [Updated: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
Dim i As Long
Dim j As Long
Dim arrPaths() As String
Dim strTemp As String
Dim strNameI As String
Dim strNameJ As String
'Proc01_Initialize collection
Set colPaths = New Collection
'Proc02_Folder selection loop
Do
With Application.FileDialog(msoFileDialogFolderPicker)
.Title = strFolderTitle
.ButtonName = strFolderPrompt
If .Show = -1 Then
colPaths.Add .SelectedItems(1)
Else
Exit Do
End If
End With
If Not m_blnAdvancedPicker Then Exit Do
lngAnswer = MsgBox("Select another folder?", _
vbYesNo + vbQuestion, "Add Folder")
If lngAnswer = vbNo Then Exit Do
Loop
'Proc03_File selection
If m_blnAdvancedPicker Then
lngAnswer = MsgBox("Select individual files too?", _
vbYesNo + vbQuestion, "Add File")
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_Return Empty if no selection
If colPaths.Count = 0 Then
Set_FileDialogFoldersFilesPicker = Empty
Exit Function
End If
'Proc05_Convert to array
ReDim arrPaths(1 To colPaths.Count)
For i = 1 To colPaths.Count
arrPaths(i) = colPaths(i)
Next i
'Proc06_Sort by name (Bubble sort)
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 return value
Set_FileDialogFoldersFilesPicker = arrPaths
End Function
Discussion