Option Explicit
'====================================================
' 【金曜日検査表】設定表つき 自動作成（フル版 / Module1貼付OK）
'
' ■やること
' 1) 操作シートで製品名・期間・SU判定範囲・（任意で計測ブックパス）を指定
' 2) 計測元ブックから期間内のシートを証跡用に全部コピー（SRC_プレフィックス）
' 3) 各日付について、設定表に従って値を取得してテンプレ検査表に貼付
' 4) 採用した計測元シート（コピー側）のタブ色を変更
'
' ■設計ポイント
' - 設定表B列のテンプレ記号（A/B/C...）→ TEMPLATE_A などを動的選択
' - N/S判定は「シート名プレフィックス」+「SU判定範囲のCountA」二重チェック
' - シート名の比較は “空白無視” （半角/全角スペース）
' - “ひらがな/カタカナ/漢字を含むシート名” は採用しない（異常系などを弾く）
' - シート名ルール（N- / S- / 区切り文字 / 日付フォーマット）は定数で集中管理
'
'====================================================
'========================
' ユーザーが触るシート名
'========================
Private Const SHEET_UI As String = "操作"
Private Const SHEET_CFG As String = "設定表"
'========================
' 操作シートのセル配置（必要なら変更）
'========================
Private Const CELL_PRODUCT As String = "B2"
Private Const CELL_DATE_FROM As String = "B3"
Private Const CELL_DATE_TO As String = "B4"
Private Const CELL_SRC_PATH As String = "B5" ' 任意：空ならユーザーが開いている計測ブックを使う
Private Const CELL_SU_RANGE As String = "B6" ' 例: X1:AD50
Private Const CELL_OUT_DIR As String = "B7" ' 任意（今回は未使用）
'========================
' 計測元シート名ルール（ここを直せば対応できる）
'========================
Private Const SHEET_PREFIX_NORMAL As String = "N" ' 通常
Private Const SHEET_PREFIX_SETUP As String = "S" ' セットアップ
Private Const SHEET_PREFIX_DELIM As String = "-" ' 区切り。必要なら "_" に変える
Private Const SHEET_DATE_FORMAT As String = "yyyy-mm-dd"
' 例：N-2026-01-20 / S-2026-01-20
' N_2026-01-20 のようにしたいなら DELIM を "_" にする
'========================
' コピーしてくる計測元（証跡用）シート名プレフィックス
'========================
Private Const SRC_COPY_PREFIX As String = "SRC_"
'========================
' シートタブ色（好みで変更）
'========================
Private Const TAB_USED_R As Long = 0
Private Const TAB_USED_G As Long = 176
Private Const TAB_USED_B As Long = 80
Private Const TAB_COPIEDONLY_R As Long = 191
Private Const TAB_COPIEDONLY_G As Long = 191
Private Const TAB_COPIEDONLY_B As Long = 191
'====================================================
' エントリーポイント
'====================================================
Public Sub BuildInspectionSheets_FromConfig()
Dim wsUI As Worksheet, wsCfg As Worksheet
Set wsUI = ThisWorkbook.Worksheets(SHEET_UI)
Set wsCfg = ThisWorkbook.Worksheets(SHEET_CFG)
Dim product As String
product = Trim$(CStr(wsUI.Range(CELL_PRODUCT).Value))
If Len(product) = 0 Then
MsgBox "操作シートの製品名が空です。", vbExclamation
Exit Sub
End If
Dim dFrom As Date, dTo As Date
If Not TryGetDate(wsUI.Range(CELL_DATE_FROM).Value, dFrom) Then
MsgBox "開始日が日付として解釈できません。", vbExclamation
Exit Sub
End If
If Not TryGetDate(wsUI.Range(CELL_DATE_TO).Value, dTo) Then
MsgBox "終了日が日付として解釈できません。", vbExclamation
Exit Sub
End If
If dTo < dFrom Then
MsgBox "終了日が開始日より前です。", vbExclamation
Exit Sub
End If
Dim suRangeAddr As String
suRangeAddr = Trim$(CStr(wsUI.Range(CELL_SU_RANGE).Value))
If Len(suRangeAddr) = 0 Then
MsgBox "SU判定範囲（例：X1:AD50）が未設定です。", vbExclamation
Exit Sub
End If
Dim srcWb As Workbook
Set srcWb = ResolveSourceWorkbook(wsUI.Range(CELL_SRC_PATH).Value)
If srcWb Is Nothing Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
On Error GoTo SafeExit
' ①期間内の計測元シートを全部コピー（証跡用）
CopySourceSheetsInPeriod srcWb, dFrom, dTo
' ②日付ごとに検査表シートを作成し、値を投入
Dim d As Date
For d = dFrom To dTo
BuildOneDay product, d, wsCfg, srcWb, suRangeAddr
Next d
MsgBox "完了しました。", vbInformation
SafeExit:
Application.EnableEvents = True
Application.ScreenUpdating = True
If Err.Number <> 0 Then
MsgBox "エラー: " & Err.Number & vbCrLf & Err.Description, vbExclamation
End If
End Sub
'====================================================
' 1日分作成
'====================================================
Private Sub BuildOneDay(ByVal product As String, ByVal targetDate As Date, _
ByVal wsCfg As Worksheet, ByVal srcWb As Workbook, _
ByVal suRangeAddr As String)
Dim templateName As String
templateName = GetTemplateNameForProduct(wsCfg, product)
If Len(templateName) = 0 Then
Err.Raise vbObjectError + 100, , "設定表に製品[" & product & "]のテンプレ指定がありません。"
End If
Dim wsTpl As Worksheet
Set wsTpl = ThisWorkbook.Worksheets(templateName)
' 検査表シートを複製
Dim wsOut As Worksheet
wsTpl.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Set wsOut = ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
Dim outName As String
outName = Format$(targetDate, "yyyy-mm-dd")
wsOut.Name = SafeUniqueSheetName(outName)
' 例：日付を A1 に入れる（必要なら設定表管理に拡張可能）
On Error Resume Next
wsOut.Range("A1").Value = targetDate
On Error GoTo 0
' 該当日の計測元シートを決定（通常名のみ採用）
Dim wsSrc As Worksheet
Set wsSrc = FindAdoptableSheet(srcWb, targetDate, suRangeAddr)
If wsSrc Is Nothing Then
MsgBox "採用可能な計測シートが見つかりません: " & Format$(targetDate, "yyyy-mm-dd"), vbExclamation
Exit Sub
End If
' 採用した元シート（検査表ブック内のコピー側）を緑にする
MarkCopiedSheetAsUsed wsSrc.Name
' 設定表から該当製品行を読み、値を貼る（丸め→R計算）
ApplyConfigRows product, wsCfg, wsSrc, wsOut
End Sub
'====================================================
' 設定表適用：丸め→R計算→貼り付け
'====================================================
Private Sub ApplyConfigRows(ByVal product As String, ByVal wsCfg As Worksheet, _
ByVal wsSrc As Worksheet, ByVal wsOut As Worksheet)
Dim lastRow As Long
lastRow = wsCfg.Cells(wsCfg.Rows.Count, "A").End(xlUp).Row
If lastRow < 2 Then Err.Raise vbObjectError + 101, , "設定表が空です。"
' R計算用に「丸め後のMAX/MIN」をキーで保持
Dim maxMap As Object, minMap As Object
Set maxMap = CreateObject("Scripting.Dictionary")
Set minMap = CreateObject("Scripting.Dictionary")
Dim r As Long
' 1) MAX/MIN/AVEなどを貼付（先に丸める）
For r = 2 To lastRow
If Trim$(CStr(wsCfg.Cells(r, "A").Value)) <> product Then GoTo ContinueRow
If Val(wsCfg.Cells(r, "K").Value) <> 1 Then GoTo ContinueRow
Dim stat As String: stat = UCase$(Trim$(CStr(wsCfg.Cells(r, "D").Value)))
Dim srcN As String: srcN = Trim$(CStr(wsCfg.Cells(r, "E").Value))
Dim srcS As String: srcS = Trim$(CStr(wsCfg.Cells(r, "F").Value))
Dim dst As String: dst = Trim$(CStr(wsCfg.Cells(r, "G").Value))
Dim factor As Double: factor = CDbl(Val(wsCfg.Cells(r, "H").Value))
If factor = 0 Then factor = 1
Dim digits As Long: digits = CLng(Val(wsCfg.Cells(r, "I").Value))
Dim rKey As String: rKey = Trim$(CStr(wsCfg.Cells(r, "J").Value))
If Len(dst) = 0 Then Err.Raise vbObjectError + 102, , "設定表の貼付先セルが空です（行 " & r & "）。"
If stat = "R" Then
' 後で計算
Else
Dim srcAddr As String
srcAddr = ChooseSrcCellByPrefix(wsSrc.Name, srcN, srcS)
If Len(srcAddr) = 0 Then Err.Raise vbObjectError + 103, , "取得セルが空です（行 " & r & "）。"
Dim rawVal As Variant
rawVal = wsSrc.Range(srcAddr).Value
If IsNumeric(rawVal) Then
Dim v As Double
v = CDbl(rawVal) * factor
v = VBA.Round(v, digits) ' 先に丸める
wsOut.Range(dst).Value = v
' R計算用に保持
If Len(rKey) > 0 Then
If stat = "MAX" Then maxMap(rKey) = v
If stat = "MIN" Then minMap(rKey) = v
End If
Else
wsOut.Range(dst).Value = vbNullString
End If
End If
ContinueRow:
Next r
' 2) Rを貼付（丸め後MAX/MINを使用）
For r = 2 To lastRow
If Trim$(CStr(wsCfg.Cells(r, "A").Value)) <> product Then GoTo ContinueRow2
If Val(wsCfg.Cells(r, "K").Value) <> 1 Then GoTo ContinueRow2
Dim stat2 As String: stat2 = UCase$(Trim$(CStr(wsCfg.Cells(r, "D").Value)))
If stat2 <> "R" Then GoTo ContinueRow2
Dim dst2 As String: dst2 = Trim$(CStr(wsCfg.Cells(r, "G").Value))
Dim rKey2 As String: rKey2 = Trim$(CStr(wsCfg.Cells(r, "J").Value))
Dim digits2 As Long: digits2 = CLng(Val(wsCfg.Cells(r, "I").Value))
If Len(dst2) = 0 Or Len(rKey2) = 0 Then GoTo ContinueRow2
If maxMap.Exists(rKey2) And minMap.Exists(rKey2) Then
Dim rr As Double
rr = CDbl(maxMap(rKey2)) - CDbl(minMap(rKey2))
rr = VBA.Round(rr, digits2) ' 念のため
wsOut.Range(dst2).Value = rr
Else
wsOut.Range(dst2).Value = vbNullString
End If
ContinueRow2:
Next r
End Sub
'====================================================
' 計測元：期間内シートを全部コピー（証跡）
'====================================================
Private Sub CopySourceSheetsInPeriod(ByVal srcWb As Workbook, ByVal dFrom As Date, ByVal dTo As Date)
Dim ws As Worksheet
For Each ws In srcWb.Worksheets
Dim d As Date
If TryExtractDateFromSheetName(ws.Name, d) Then
If d >= dFrom And d <= dTo Then
ws.Copy After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
With ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count)
.Name = SafeUniqueSheetName(SRC_COPY_PREFIX & ws.Name)
.Tab.Color = RGB(TAB_COPIEDONLY_R, TAB_COPIEDONLY_G, TAB_COPIEDONLY_B)
End With
End If
End If
Next ws
End Sub
' 採用した元シート（コピー側）を緑タブにする
Private Sub MarkCopiedSheetAsUsed(ByVal originalSrcSheetName As String)
Dim targetKey As String
targetKey = NormalizeSheetName(SRC_COPY_PREFIX & originalSrcSheetName)
Dim ws As Worksheet
For Each ws In ThisWorkbook.Worksheets
If NormalizeSheetName(ws.Name) = targetKey Then
ws.Tab.Color = RGB(TAB_USED_R, TAB_USED_G, TAB_USED_B)
Exit Sub
End If
Next ws
End Sub
'====================================================
' 計測元：採用できるシートを探す
' - 通常名のみ採用（N/S + 日付）
' - “ひらがな/カタカナ/漢字を含む”シート名は採用しない
' - 空白は無視して照合
' - 名前判定とSU範囲判定を二重チェック
'====================================================
Private Function FindAdoptableSheet(ByVal srcWb As Workbook, ByVal targetDate As Date, ByVal suRangeAddr As String) As Worksheet
Dim wantN As String, wantS As String
wantN = BuildExpectedSheetName(False, targetDate) ' N-
wantS = BuildExpectedSheetName(True, targetDate) ' S-
' 直接参照は“微妙な命名差”で落ちるので、全シート走査で一致判定する
Dim ws As Worksheet
Dim wsN As Worksheet, wsS As Worksheet
For Each ws In srcWb.Worksheets
If ContainsJapaneseChars(ws.Name) Then
' 異常などの日本語入りは採用しない
Else
If NormalizeSheetName(ws.Name) = NormalizeSheetName(wantN) Then Set wsN = ws
If NormalizeSheetName(ws.Name) = NormalizeSheetName(wantS) Then Set wsS = ws
End If
Next ws
' まず S を優先
If Not wsS Is Nothing Then
If IsConsistentMode(wsS, True, suRangeAddr) Then
Set FindAdoptableSheet = wsS
Exit Function
Else
MsgBox "Sシートの判定が矛盾（名前/SU範囲）: " & wsS.Name, vbExclamation
Exit Function
End If
End If
If Not wsN Is Nothing Then
If IsConsistentMode(wsN, False, suRangeAddr) Then
Set FindAdoptableSheet = wsN
Exit Function
Else
MsgBox "Nシートの判定が矛盾（名前/SU範囲）: " & wsN.Name, vbExclamation
Exit Function
End If
End If
Set FindAdoptableSheet = Nothing
End Function
Private Function IsConsistentMode(ByVal ws As Worksheet, ByVal shouldBeSetup As Boolean, ByVal suRangeAddr As String) As Boolean
Dim isSU_byCells As Boolean
isSU_byCells = IsSetupModeByRange(ws, suRangeAddr)
If shouldBeSetup Then
IsConsistentMode = (isSU_byCells = True)
Else
IsConsistentMode = (isSU_byCells = False)
End If
End Function
Private Function IsSetupModeByRange(ByVal ws As Worksheet, ByVal addr As String) As Boolean
On Error GoTo EH
IsSetupModeByRange = (WorksheetFunction.CountA(ws.Range(addr)) > 0)
Exit Function
EH:
IsSetupModeByRange = False
End Function
'====================================================
' ヘルパー（テンプレ名）
' 設定表B列が「A」→ TEMPLATE_A
'====================================================
Private Function GetTemplateNameForProduct(ByVal wsCfg As Worksheet, ByVal product As String) As String
Dim lastRow As Long
lastRow = wsCfg.Cells(wsCfg.Rows.Count, "A").End(xlUp).Row
Dim r As Long
For r = 2 To lastRow
If Trim$(CStr(wsCfg.Cells(r, "A").Value)) = product Then
Dim t As String
t = Trim$(CStr(wsCfg.Cells(r, "B").Value))
If Len(t) > 0 Then
t = UCase$(t)
GetTemplateNameForProduct = "TEMPLATE_" & t
Exit Function
End If
End If
Next r
End Function
'====================================================
' ヘルパー（通常/セットアップで取得セルを切替）
'====================================================
Private Function ChooseSrcCellByPrefix(ByVal sheetName As String, ByVal srcN As String, ByVal srcS As String) As String
If IsSetupSheetName(sheetName) Then
ChooseSrcCellByPrefix = srcS
Else
ChooseSrcCellByPrefix = srcN
End If
End Function
Private Function IsSetupSheetName(ByVal sheetName As String) As Boolean
Dim s As String
s = NormalizeSheetName(sheetName)
IsSetupSheetName = (Left$(s, Len(SHEET_PREFIX_SETUP & SHEET_PREFIX_DELIM)) = NormalizeSheetName(SHEET_PREFIX_SETUP & SHEET_PREFIX_DELIM))
End Function
'====================================================
' ヘルパー（シート名を安全に一意化）
'====================================================
Private Function SafeUniqueSheetName(ByVal baseName As String) As String
Dim nameTry As String: nameTry = baseName
Dim i As Long: i = 1
Do While SheetExists(nameTry)
i = i + 1
nameTry = Left$(baseName, 25) & "_" & i
Loop
SafeUniqueSheetName = nameTry
End Function
Private Function SheetExists(ByVal sheetName As String) As Boolean
Dim ws As Worksheet
On Error Resume Next
Set ws = ThisWorkbook.Worksheets(sheetName)
SheetExists = Not ws Is Nothing
On Error GoTo 0
End Function
'====================================================
' シート名から日付を抽出（証跡コピー用）
'====================================================
Private Function TryExtractDateFromSheetName(ByVal sheetName As String, ByRef outDate As Date) As Boolean
Dim s As String
s = Trim$(sheetName)
' 空白は無視（半角/全角）
s = NormalizeSheetName(s)
' N/Sプレフィックス除去（例：N- / S-）
Dim pN As String, pS As String
pN = NormalizeSheetName(SHEET_PREFIX_NORMAL & SHEET_PREFIX_DELIM)
pS = NormalizeSheetName(SHEET_PREFIX_SETUP & SHEET_PREFIX_DELIM)
If Left$(s, Len(pN)) = pN Then s = Mid$(s, Len(pN) + 1)
If Left$(s, Len(pS)) = pS Then s = Mid$(s, Len(pS) + 1)
' まず yyyy-mm-dd を試す（先頭10文字）
If Len(s) >= 10 Then
If TryGetDate(Left$(s, 10), outDate) Then
TryExtractDateFromSheetName = True
Exit Function
End If
End If
' フォールバック
TryExtractDateFromSheetName = TryGetDate(s, outDate)
End Function
'====================================================
' 日付判定
'====================================================
Private Function TryGetDate(ByVal v As Variant, ByRef outDate As Date) As Boolean
On Error GoTo EH
If IsDate(v) Then
outDate = CDate(v)
TryGetDate = True
Exit Function
End If
EH:
TryGetDate = False
End Function
'====================================================
' 計測ブック取得
'====================================================
Private Function ResolveSourceWorkbook(ByVal pathValue As Variant) As Workbook
Dim p As String
p = Trim$(CStr(pathValue))
' 1) パス指定があれば開く（読取専用）
If Len(p) > 0 Then
If Dir(p) = "" Then
MsgBox "計測ブックのパスが見つかりません: " & p, vbExclamation
Exit Function
End If
Set ResolveSourceWorkbook = Workbooks.Open(Filename:=p, ReadOnly:=True, UpdateLinks:=False)
Exit Function
End If
' 2) パスが無い場合：開いているブックから選ぶ
If Application.Workbooks.Count <= 1 Then
MsgBox "計測データブックが開かれていません。パス指定するか、先に開いてください。", vbExclamation
Exit Function
End If
Set ResolveSourceWorkbook = ActiveWorkbook
End Function
'====================================================
' 期待するシート名（N/S + 日付）を生成
'====================================================
Private Function BuildExpectedSheetName(ByVal isSetup As Boolean, ByVal d As Date) As String
Dim prefix As String
If isSetup Then
prefix = SHEET_PREFIX_SETUP
Else
prefix = SHEET_PREFIX_NORMAL
End If
BuildExpectedSheetName = prefix & SHEET_PREFIX_DELIM & Format$(d, SHEET_DATE_FORMAT)
End Function
'====================================================
' シート名の正規化（空白無視）
'====================================================
Private Function NormalizeSheetName(ByVal s As String) As String
Dim t As String
t = CStr(s)
' 半角/全角スペース・タブを除去
t = Replace(t, " ", vbNullString)
t = Replace(t, ChrW(&H3000), vbNullString) ' 全角スペース
t = Replace(t, vbTab, vbNullString)
NormalizeSheetName = t
End Function
'====================================================
' 日本語（ひらがな/カタカナ/漢字）が含まれるか
'====================================================
Private Function ContainsJapaneseChars(ByVal s As String) As Boolean
Dim i As Long, c As Long
For i = 1 To Len(s)
c = AscW(Mid$(s, i, 1))
' ひらがな
If c >= &H3040 And c <= &H309F Then ContainsJapaneseChars = True: Exit Function
' カタカナ
If c >= &H30A0 And c <= &H30FF Then ContainsJapaneseChars = True: Exit Function
' CJK統合漢字（ざっくり）
If c >= &H4E00 And c <= &H9FFF Then ContainsJapaneseChars = True: Exit Function
Next i
End Function
ーーーーーーーー
ーーーーーーーー
ーーーーーーーー
ひな型剥製用
Option Explicit
Public Sub 雛形ブック作成_設定表作成用マクロ2()
Dim savePath As String
savePath = PickSavePath("設定表作成用マクロ2_会社用.xlsm")
If Len(savePath) = 0 Then Exit Sub
Application.ScreenUpdating = False
Application.EnableEvents = False
Dim wbNew As Workbook
Set wbNew = Workbooks.Add(xlWBATWorksheet)
' xlsmで保存（マクロを貼れる器を作る）
wbNew.SaveAs Filename:=savePath, FileFormat:=xlOpenXMLWorkbookMacroEnabled
Dim wsOp As Worksheet, wsList As Worksheet, wsIn As Worksheet
Set wsOp = GetOrCreateSheet(wbNew, "操作シート")
Set wsList = GetOrCreateSheet(wbNew, "設定表_リスト")
Set wsIn = GetOrCreateSheet(wbNew, "入力用")
CleanupDefaultSheets wbNew, Array(wsOp.Name, wsList.Name, wsIn.Name)
Build_tblList wsList
Build_tblSrc wsList
Build_OperationUI wsOp
Build_InputSheetSkeleton wsIn
Build_OperationButtons wbNew, wsOp
Application.EnableEvents = True
Application.ScreenUpdating = True
MsgBox "雛形ブックを作成したよ！" & vbCrLf & savePath & vbCrLf & _
"次にVBEで標準モジュールを追加して、下の②③…を順番に貼ってね。", vbInformation
End Sub
'-----------------------------
' 保存先選択
'-----------------------------
Private Function PickSavePath(ByVal defaultName As String) As String
Dim fd As FileDialog
Set fd = Application.FileDialog(msoFileDialogSaveAs)
With fd
.Title = "雛形ブックの保存先（xlsm）を選んでね"
.InitialFileName = defaultName
If .Show <> -1 Then
PickSavePath = ""
Else
PickSavePath = .SelectedItems(1)
If LCase$(Right$(PickSavePath, 5)) <> ".xlsm" Then
PickSavePath = PickSavePath & ".xlsm"
End If
End If
End With
End Function
'-----------------------------
' シート取得/作成
'-----------------------------
Private Function GetOrCreateSheet(ByVal wb As Workbook, ByVal nm As String) As Worksheet
On Error Resume Next
Set GetOrCreateSheet = wb.Worksheets(nm)
On Error GoTo 0
If GetOrCreateSheet Is Nothing Then
Set GetOrCreateSheet = wb.Worksheets.Add(After:=wb.Worksheets(wb.Worksheets.Count))
GetOrCreateSheet.Name = nm
End If
End Function
Private Sub CleanupDefaultSheets(ByVal wb As Workbook, ByVal keepNames As Variant)
Dim ws As Worksheet, i As Long, keep As Boolean
Application.DisplayAlerts = False
For Each ws In wb.Worksheets
keep = False
For i = LBound(keepNames) To UBound(keepNames)
If ws.Name = keepNames(i) Then keep = True
Next
If Not keep Then ws.Delete
Next
Application.DisplayAlerts = True
End Sub
'-----------------------------
' 設定表_リスト：tblList（入力規則リスト用）
'-----------------------------
Private Sub Build_tblList(ByVal ws As Worksheet)
ws.Cells.Clear
Dim headers As Variant
headers = Array("品名", "テンプレート", "項目", "統計", "取得セル_N", "取得セル_S", "貼り付け先セル", "変換係数", "丸め桁", "Rキー", "有効")
Dim c As Long
For c = 0 To UBound(headers)
ws.Cells(1, 1 + c).Value = headers(c)
ws.Cells(1, 1 + c).Font.Bold = True
Next
' サンプル（会社で後から自由に変更OK）
ws.Range("A2").Value = "品名A"
ws.Range("A3").Value = "品名B"
ws.Range("D2").Value = "MAX"
ws.Range("D3").Value = "MIN"
ws.Range("D4").Value = "AVE"
ws.Range("D5").Value = "R"
ws.Range("H2").Value = 1
ws.Range("H3").Value = 0.10197
ws.Range("K2").Value = "TRUE"
ws.Range("K3").Value = "FALSE"
Dim lastRow As Long
lastRow = Application.Max( _
ws.Cells(ws.Rows.Count, "A").End(xlUp).Row, _
ws.Cells(ws.Rows.Count, "D").End(xlUp).Row, _
ws.Cells(ws.Rows.Count, "H").End(xlUp).Row, _
ws.Cells(ws.Rows.Count, "K").End(xlUp).Row _
)
If lastRow < 2 Then lastRow = 2
On Error Resume Next
ws.ListObjects("tblList").Delete
On Error GoTo 0
Dim lo As ListObject
Set lo = ws.ListObjects.Add(xlSrcRange, ws.Range("A1:K" & lastRow), , xlYes)
lo.Name = "tblList"
ws.Columns("A:K").AutoFit
End Sub
'-----------------------------
' 設定表_リスト：tblSrc（品名→ブックパス）
'-----------------------------
Private Sub Build_tblSrc(ByVal ws As Worksheet)
Dim startRow As Long
startRow = ws.Cells(ws.Rows.Count, "A").End(xlUp).Row + 3
ws.Cells(startRow, 1).Value = "品名"
ws.Cells(startRow, 2).Value = "ブックパス"
ws.Range(ws.Cells(startRow, 1), ws.Cells(startRow, 2)).Font.Bold = True
ws.Cells(startRow + 1, 1).Value = "品名A"
ws.Cells(startRow + 2, 1).Value = "品名B"
ws.Cells(startRow + 1, 2).Value = "後で入力"
ws.Cells(startRow + 2, 2).Value = "後で入力"
On Error Resume Next
ws.ListObjects("tblSrc").Delete
On Error GoTo 0
Dim lo As ListObject
Set lo = ws.ListObjects.Add(xlSrcRange, ws.Range(ws.Cells(startRow, 1), ws.Cells(startRow + 2, 2)), , xlYes)
lo.Name = "tblSrc"
ws.Columns("A:B").AutoFit
End Sub
'-----------------------------
' 操作シートUI（最低限）
'-----------------------------
Private Sub Build_OperationUI(ByVal ws As Worksheet)
ws.Cells.Clear
ws.Cells.Font.Name = "Meiryo UI"
ws.Cells.Font.Size = 10
ws.Range("B2").Value = "製品選択"
ws.Range("B2").Font.Bold = True
' 図形ボタンを載せるベースセル
ws.Range("B3").Value = "製品A"
ws.Range("D3").Value = "製品B"
ws.Range("B3").HorizontalAlignment = xlCenter
ws.Range("D3").HorizontalAlignment = xlCenter
ws.Range("B3:D3").Font.Bold = True
ws.Range("B3").BorderAround
ws.Range("D3").BorderAround
ws.Range("B5").Value = "送付日"
ws.Range("C5").Interior.Color = RGB(180, 220, 255)
ws.Range("C5").BorderAround
ws.Range("B7").Value = "製造日"
ws.Range("C7:C14").Interior.Color = RGB(180, 220, 255)
ws.Range("C7:C14").BorderAround
ws.Range("O3").Value = "選択中のブックパス"
ws.Range("Q3").NumberFormat = "@"
ws.Columns("Q").ColumnWidth = 60
ws.Columns("B:C").ColumnWidth = 14
End Sub
'-----------------------------
' 入力用シート（空の器だけ）
'-----------------------------
Private Sub Build_InputSheetSkeleton(ByVal ws As Worksheet)
ws.Cells.Clear
ws.Cells.Font.Name = "Meiryo UI"
ws.Cells.Font.Size = 10
ws.Range("A1").Value = "※ここに設定テーブル（tblInput）を作る（後でマクロ貼って作成）"
End Sub
'-----------------------------
' 操作シート：図形ボタン作成（名前固定）
'-----------------------------
Private Sub Build_OperationButtons(ByVal wb As Workbook, ByVal ws As Worksheet)
DeleteShapeIfExists ws, "btn製品A"
DeleteShapeIfExists ws, "btn製品B"
DeleteShapeIfExists ws, "btn作成"
DeleteShapeIfExists ws, "btnクリア"
Dim shpA As Shape, shpB As Shape, shpMake As Shape, shpClear As Shape
Set shpA = AddButtonOnCell(ws, "B3", "製品A", "btn製品A")
shpA.OnAction = "'" & wb.Name & "'!Select_Product_A"
Set shpB = AddButtonOnCell(ws, "D3", "製品B", "btn製品B")
shpB.OnAction = "'" & wb.Name & "'!Select_Product_B"
Set shpMake = AddButtonOnCell(ws, "B16", "作成", "btn作成")
shpMake.OnAction = "'" & wb.Name & "'!Run_Create"
Set shpClear = AddButtonOnCell(ws, "D16", "クリア", "btnクリア")
shpClear.OnAction = "'" & wb.Name & "'!Run_Clear"
End Sub
Private Sub DeleteShapeIfExists(ByVal ws As Worksheet, ByVal shapeName As String)
On Error Resume Next
ws.Shapes(shapeName).Delete
On Error GoTo 0
End Sub
Private Function AddButtonOnCell(ByVal ws As Worksheet, ByVal addr As String, ByVal caption As String, ByVal shapeName As String) As Shape
Dim r As Range: Set r = ws.Range(addr)
Dim shp As Shape
Set shp = ws.Shapes.AddShape(msoShapeRoundedRectangle, r.Left, r.Top, r.Width, r.Height)
shp.Name = shapeName
shp.TextFrame2.TextRange.Text = caption
shp.TextFrame2.TextRange.Font.Size = 11
shp.TextFrame2.TextRange.Font.Bold = msoTrue
shp.TextFrame2.TextRange.ParagraphFormat.Alignment = msoAlignCenter
shp.Fill.ForeColor.RGB = RGB(255, 255, 255)
shp.Line.ForeColor.RGB = RGB(120, 120, 120)
shp.Placement = xlFreeFloating ' ズレにくい
Set AddButtonOnCell = shp
End Function
ーーーーーーーー
ーーーーーーーー
ーーーーーーーー
標準モジュール
Option Explicit
Private Const SHEET_UI As String = "操作シート"
Private Const SHEET_LIST As String = "設定表_リスト"
Private Const TABLE_SRC As String = "tblSrc"
Private Const CELL_PATH As String = "Q3"
Private Const BTN_A As String = "btn製品A"
Private Const BTN_B As String = "btn製品B"
' tblSrc の「品名」列に入っている文字と一致させる
Private Const PROD_A As String = "品名A"
Private Const PROD_B As String = "品名B"
Public Sub Select_Product_A()
ApplyProductSelection PROD_A, BTN_A
End Sub
Public Sub Select_Product_B()
ApplyProductSelection PROD_B, BTN_B
End Sub
Public Sub Run_Create()
'★ここに「書類作成処理」を後で入れていく
' いまはUIリセットだけ動かす
UI_Reset
MsgBox "作成処理（仮）完了：初期状態へ戻しました。", vbInformation
End Sub
Public Sub Run_Clear()
UI_Reset
End Sub
Private Sub ApplyProductSelection(ByVal productName As String, ByVal btnName As String)
Dim wsUI As Worksheet: Set wsUI = ThisWorkbook.Worksheets(SHEET_UI)
Dim path As String
path = LookupBookPath(productName)
If Len(path) = 0 Then
MsgBox "tblSrc に [" & productName & "] のブックパスが見つからないよ。", vbExclamation
Exit Sub
End If
wsUI.Range(CELL_PATH).Value = path
'押したボタンだけ色変更（もう片方は触らない）
wsUI.Shapes(btnName).Fill.ForeColor.RGB = RGB(180, 220, 255)
End Sub
Private Function LookupBookPath(ByVal productName As String) As String
Dim ws As Worksheet: Set ws = ThisWorkbook.Worksheets(SHEET_LIST)
Dim lo As ListObject: Set lo = ws.ListObjects(TABLE_SRC)
Dim colProd As Long: colProd = lo.ListColumns("品名").Index
Dim colPath As Long: colPath = lo.ListColumns("ブックパス").Index
Dim r As ListRow
For Each r In lo.ListRows
If CStr(r.Range.Cells(1, colProd).Value) = productName Then
LookupBookPath = CStr(r.Range.Cells(1, colPath).Value)
Exit Function
End If
Next r
LookupBookPath = ""
End Function
Private Sub UI_Reset()
Dim wsUI As Worksheet: Set wsUI = ThisWorkbook.Worksheets(SHEET_UI)
'パスクリア
wsUI.Range(CELL_PATH).ClearContents
'水色入力欄クリア（あなたの画面に合わせた範囲）
wsUI.Range("C5").ClearContents
wsUI.Range("C7:C14").ClearContents
'ボタン色を初期化（未選択＝白）
On Error Resume Next
wsUI.Shapes(BTN_A).Fill.ForeColor.RGB = RGB(255, 255, 255)
wsUI.Shapes(BTN_B).Fill.ForeColor.RGB = RGB(255, 255, 255)
On Error GoTo 0
End Sub
ーーーーーーーーー
ーーーーーーーー
ーーーーーーーー
Option Explicit
'========================
' 入力用テーブル(tblInput) 作成
' - 入力用シートに品名～有効のテーブルを作る
' - 設定表_リストの tblList を参照して入力規則を付与
'========================
Public Sub Build_tblInput()
Const SHEET_INPUT As String = "入力用"
Const SHEET_LIST As String = "設定表_リスト"
Const TBL_INPUT As String = "tblInput"
Const TBL_LIST As String = "tblList"
Const HEADER_ROW As Long = 1
Const DATA_ROWS As Long = 500 ' 入力行数（必要なら増やしてOK）
Const COL_END As Long = 11 ' A～K
Dim wb As Workbook: Set wb = ThisWorkbook
Dim wsI As Worksheet, wsL As Worksheet
Set wsI = wb.Worksheets(SHEET_INPUT)
Set wsL = wb.Worksheets(SHEET_LIST)
Application.ScreenUpdating = False
Application.EnableEvents = False
'==== 入力用シート初期化（必要に応じて）
wsI.Cells.Clear
'==== 見出し
Dim headers As Variant
headers = Array( _
"品名", "テンプレート", "項目", "統計", _
"取得セル_N", "取得セル_S", "貼り付け先セル", _
"変換係数", "丸め桁", "Rキー", "有効" _
)
Dim c As Long
For c = 0 To UBound(headers)
wsI.Cells(HEADER_ROW, 1 + c).Value = headers(c)
wsI.Cells(HEADER_ROW, 1 + c).Font.Bold = True
wsI.Cells(HEADER_ROW, 1 + c).Interior.Color = RGB(230, 230, 230)
Next c
'==== 既存tblInput削除
On Error Resume Next
wsI.ListObjects(TBL_INPUT).Delete
On Error GoTo 0
'==== tblInput 作成（A1:K(1+DATA_ROWS)）
Dim loI As ListObject
Set loI = wsI.ListObjects.Add( _
SourceType:=xlSrcRange, _
Source:=wsI.Range(wsI.Cells(HEADER_ROW, 1), wsI.Cells(HEADER_ROW + DATA_ROWS, COL_END)), _
XlListObjectHasHeaders:=xlYes)
loI.Name = TBL_INPUT
' 見た目
wsI.Columns("A").ColumnWidth = 18
wsI.Columns("B").ColumnWidth = 18
wsI.Columns("C").ColumnWidth = 18
wsI.Columns("D").ColumnWidth = 10
wsI.Columns("E").ColumnWidth = 14
wsI.Columns("F").ColumnWidth = 14
wsI.Columns("G").ColumnWidth = 14
wsI.Columns("H").ColumnWidth = 12
wsI.Columns("I").ColumnWidth = 10
wsI.Columns("J").ColumnWidth = 10
wsI.Columns("K").ColumnWidth = 8
wsI.Cells.Font.Name = "Meiryo UI"
wsI.Cells.Font.Size = 10
'==== tblList があるかチェック
Dim loL As ListObject
On Error Resume Next
Set loL = wsL.ListObjects(TBL_LIST)
On Error GoTo 0
If loL Is Nothing Then
MsgBox "設定表_リストに tblList が見つからないよ。先に雛形作成を実行してね。", vbExclamation
GoTo CleanExit
End If
'==== 名前定義（lst_itemA～K）を tblList から作成/更新（堅牢版）
CreateOrReplaceListNames_FromTblList wb, loL
'==== 入力規則（tblInputの各列に付与）
SetValidation loI, "品名", "=lst_itemA"
SetValidation loI, "テンプレート", "=lst_itemB"
SetValidation loI, "項目", "=lst_itemC"
SetValidation loI, "統計", "=lst_itemD"
SetValidation loI, "取得セル_N", "=lst_itemE"
SetValidation loI, "取得セル_S", "=lst_itemF"
SetValidation loI, "貼り付け先セル", "=lst_itemG"
SetValidation loI, "変換係数", "=lst_itemH"
SetValidation loI, "丸め桁", "=lst_itemI"
SetValidation loI, "Rキー", "=lst_itemJ"
SetValidation loI, "有効", "=lst_itemK"
MsgBox "入力用シートに tblInput を作成したよ！", vbInformation
CleanExit:
Application.EnableEvents = True
Application.ScreenUpdating = True
End Sub
'========================
' 名前定義（堅牢版：tblList列のRangeから作る）
'========================
Private Sub CreateOrReplaceListNames_FromTblList(ByVal wb As Workbook, ByVal lo As ListObject)
SetOrReplaceNameToRange wb, "lst_itemA", lo, "品名"
SetOrReplaceNameToRange wb, "lst_itemB", lo, "テンプレート"
SetOrReplaceNameToRange wb, "lst_itemC", lo, "項目"
SetOrReplaceNameToRange wb, "lst_itemD", lo, "統計"
SetOrReplaceNameToRange wb, "lst_itemE", lo, "取得セル_N"
SetOrReplaceNameToRange wb, "lst_itemF", lo, "取得セル_S"
SetOrReplaceNameToRange wb, "lst_itemG", lo, "貼り付け先セル"
SetOrReplaceNameToRange wb, "lst_itemH", lo, "変換係数"
SetOrReplaceNameToRange wb, "lst_itemI", lo, "丸め桁"
SetOrReplaceNameToRange wb, "lst_itemJ", lo, "Rキー"
SetOrReplaceNameToRange wb, "lst_itemK", lo, "有効"
End Sub
Private Sub SetOrReplaceNameToRange(ByVal wb As Workbook, ByVal nm As String, ByVal lo As ListObject, ByVal colHeader As String)
Dim rng As Range
On Error GoTo EH
Set rng = lo.ListColumns(colHeader).DataBodyRange
' 0件でも落とさない（1セルだけ参照）
If rng Is Nothing Then
Set rng = lo.HeaderRowRange.Cells(1, lo.ListColumns(colHeader).Index).Offset(1, 0)
End If
On Error Resume Next
wb.Names(nm).Delete
On Error GoTo 0
wb.Names.Add Name:=nm, RefersTo:="=" & rng.Address(External:=True)
Exit Sub
EH:
MsgBox "名前定義 '" & nm & "' 作成失敗：列 '" & colHeader & "' が tblList に無いかも。", vbExclamation
End Sub
'========================
' 入力規則（テーブル列へ）
'========================
Private Sub SetValidation(ByVal lo As ListObject, ByVal colName As String, ByVal formula As String)
With lo.ListColumns(colName).DataBodyRange.Validation
.Delete
.Add Type:=xlValidateList, AlertStyle:=xlValidAlertStop, Operator:=xlBetween, Formula1:=formula
.IgnoreBlank = True
.InCellDropdown = True
.ShowInput = True
.ShowError = True
End With
End Sub