画面情報取得方法検討マクロ

Option Explicit
'================================================================
' DiagDom : 診断一式（環境 / DOM取得可否 / 画面構造ダンプ）
'  ・画面内の文字は伏せ字化して出力（ラベル語だけ元のまま）
'      漢字→漢  ひらがな→あ  カタカナ→ア  数字→9  英字→A,a
'      半角空白→_  全角空白→□  記号(-:()/,.など)はそのまま
'  ・実行手順: 新システムの画面をEdgeで開いたまま「診断一式」を実行
'  ・対応: Excel 2010以降(VBA7)
'  ・このモジュールの InitLabels / Mask / SafeAttr は DiagUia からも使います
'================================================================
Private Const MAX_ROWS As Long = 30000
Private Const COLS As Long = 14
Private Const EXT_CHECK As Boolean = False   'True: PowerShell/デバッグポート確認(職場の監視に注意)

#If VBA7 Then
    Private Declare PtrSafe Function EnumWindows Lib "user32" (ByVal lpEnumFunc As LongPtr, ByVal lParam As LongPtr) As Long
    Private Declare PtrSafe Function GetWindowTextW Lib "user32" (ByVal hWnd As LongPtr, ByVal lpString As LongPtr, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function GetClassNameW Lib "user32" (ByVal hWnd As LongPtr, ByVal lpClassName As LongPtr, ByVal nMaxCount As Long) As Long
    Private Declare PtrSafe Function IsWindowVisible Lib "user32" (ByVal hWnd As LongPtr) As Long
#End If

Private gData() As Variant
Private gN As Long
Private gLabels As Variant
Private gWinList As String
Private gChromeOther As Long
Private gSum As Worksheet
Private gSumR As Long
Private gClsCnt As Object
Private gIdDup As Object
Private gIdN As Long
Private gIdShort As Long
Private gElN As Long
Private gHidInput As Long
Private gHidNone As Long
Private gHidZero As Long
Private gCmtN As Long
Private gHidList As String
Private gDocs As Long
Private gLogPath As String
Private gErrList As String
Private gErrTotal As Long

'---------------------------------------------------------------
Public Sub 診断一式()
    Dim kw As String, stamp As String
    Dim sh As Object, w As Object, doc As Object
    Dim i As Long, n As Long, nHtml As Long, nKey As Long, pg As Long
    Dim tn As String, ln As String
    Dim lines() As String, pr() As String
    Dim wsD As Worksheet, wsL As Worksheet

    StpReset
    Stp "診断開始"
    InitLabels
    kw = InputBox("対象画面のタイトルの一部を入力してください。" & vbLf & _
                  "空欄でOK（見つかったHTMLDocumentをすべて調べます）", "診断一式")
    stamp = Format(Now, "mmdd_hhnn")

    gN = 0: gDocs = 0: gElN = 0: gIdN = 0: gIdShort = 0
    gHidInput = 0: gHidNone = 0: gHidZero = 0: gCmtN = 0: gHidList = ""
    ReDim gData(1 To MAX_ROWS, 1 To COLS)
    Stp "Scripting.Dictionary作成(class/id集計用)"
    Set gClsCnt = CreateObject("Scripting.Dictionary")
    Set gIdDup = CreateObject("Scripting.Dictionary")

    Stp "診断シート追加(サマリ)"
    Set gSum = ThisWorkbook.Worksheets.Add
    gSum.Name = "サマリ" & stamp
    gSum.Columns("A:C").NumberFormat = "@"
    gSumR = 1

    SPut "■環境"
    SPut "診断日時", Format(Now, "yyyy/mm/dd hh:nn:ss")
    SPut "Excel / OS", Application.Version & " / " & Application.OperatingSystem
    #If Win64 Then
        SPut "VBA", "64bit"
    #Else
        SPut "VBA", "32bit"
    #End If
    SPut "対象タイトル指定", IIf(kw = "", "(空欄)", kw)
    If EXT_CHECK Then ExtCheck

    '--- Win32でEdge/IEウィンドウを列挙（IEモードでなくても画面名が分かる）
    gWinList = "": gChromeOther = 0
    Stp "Win32 EnumWindows(user32)"
    EnumWindows AddressOf EnumProc, 0
    SPut "■Edge/IEウィンドウ(Win32列挙)"
    SPut "クラス", "画面名"
    lines = Split(gWinList, vbLf)
    For i = 0 To UBound(lines)
        If Len(lines(i)) > 0 Then
            pr = Split(lines(i), vbTab)
            SPut pr(0), pr(1)
        End If
    Next
    SPut "Edge表記なしのChrome系ウィンドウ数", CStr(gChromeOther)

    '--- Shell.Application: IEモードのウィンドウならHTMLDocumentとして見える
    SPut "■Shell.Applicationのウィンドウ(IEモード判定)"
    SPut "種類(TypeName)", "画面名", "URL(?より前)"
    Stp "Shell.Application作成"
    On Error Resume Next
    Set sh = CreateObject("Shell.Application")
    ErrNote "CreateObject(Shell.Application)"
    n = sh.Windows.Count
    ErrNote "Shell.Windows.Count"
    Stp "Shell.Windowsを列挙(" & n & "件)"
    For i = 0 To n - 1
        Set w = Nothing
        Set w = sh.Windows.Item(i)
        ErrNote "Shell.Windows.Item"
        If Not w Is Nothing Then
            tn = "": ln = ""
            tn = TypeName(w.Document)
            ErrNote "w.Document"
            ln = w.LocationName
            ErrNote "w.LocationName"
            SPut tn, ln, Split(w.LocationURL & "?", "?")(0)
            ErrNote "w.LocationURL"
            If tn = "HTMLDocument" Then
                nHtml = nHtml + 1
                If kw = "" Or InStr(ln, kw) > 0 Then
                    Set doc = Nothing
                    Set doc = w.Document
                    ErrNote "Set doc = w.Document"
                    If Not doc Is Nothing Then
                        Stp "DOM取得開始 W" & nHtml
                        DumpDoc doc, "W" & nHtml, 0
                        Stp "DOM取得完了 W" & nHtml & " (累計行数=" & gN & ")"
                    End If
                End If
            End If
        End If
    Next
    On Error GoTo 0

    SPut "HTMLDocument件数", CStr(nHtml)
    If nHtml = 0 Then
        SPut "判定", "HTMLDocumentなし = IEモード方式のDOM取得は不可", "→ DiagUia の UIA診断 を実行"
    Else
        SPut "判定", "HTMLDocumentあり = DOM取得方式が使える可能性", ""
    End If

    Stp "統計集計(サマリ)"
    SumTail

    Stp "ラベル周辺シート作成"
    Set wsL = ThisWorkbook.Worksheets.Add
    wsL.Name = "ラベル周辺" & stamp
    WriteLabelCtx wsL

    Stp "DOMシート書き出し(" & gN & "行)"
    Set wsD = ThisWorkbook.Worksheets.Add
    wsD.Name = "DOM" & stamp
    nKey = WriteDom(wsD)

    '--- 書式・印刷設定
    Stp "書式・印刷設定"
    FmtSheet gSum, 9, False, ""
    SetWidths gSum, Array(34, 60, 40)
    gSum.Columns("B:C").WrapText = True
    gSum.UsedRange.Rows.AutoFit

    FmtSheet wsL, 8, True, "$1:$1"
    SetWidths wsL, Array(9, 6, 4, 4, 9, 22, 26, 9, 46, 40)

    FmtSheet wsD, 8, True, "$1:$1"
    SetWidths wsD, Array(6, 4, 4, 9, 22, 28, 12, 7, 12, 46, 6, 38, 40, 5)
    If gN > 0 Then
        On Error Resume Next
        wsD.PageSetup.PrintArea = wsD.Range("A1").Resize(gN + 1, 12).Address
        On Error GoTo 0
    End If

    gSum.Activate
    pg = nKey \ 45 + 1
    If MsgBox("診断シートができました。印刷しますか？" & vbLf & _
              "・サマリ / ラベル周辺 / DOM(要点のみ 約" & pg & "ページ)" & vbLf & _
              "※個人情報は伏せ字化していますが、印刷後に目視で確認してください。", _
              vbYesNo + vbQuestion, "診断一式") = vbYes Then
        Stp "印刷(サマリ)": gSum.PrintOut
        Stp "印刷(ラベル周辺)": wsL.PrintOut
        Stp "印刷(DOM)": wsD.PrintOut
    End If
    Stp "完了"
    Application.StatusBar = False
End Sub

'---------------------------------------------------------------
Public Sub StpReset()
    gLogPath = ""
    gErrList = ""
    gErrTotal = 0
End Sub

Public Sub Stp(ByVal s As String)
    '各ステップの「開始」を記録（途中で止まっても最後の行で場所が分かる）
    Dim f As Integer
    If Len(gLogPath) = 0 Then gLogPath = Environ("TEMP") & "\diag_step_" & Format(Now, "mmdd_hhnn") & ".log"
    Application.StatusBar = "診断: " & s
    On Error Resume Next
    f = FreeFile
    Open gLogPath For Append As #f
    Print #f, Format(Now, "hh:nn:ss") & " " & s
    Close #f
End Sub

Public Sub ErrNote(ByVal stepName As String)
    '直前の読み取りで起きたエラーを記録して続行
    Dim key As String
    If Err.Number = 0 Then Exit Sub
    key = stepName & " / Err" & Err.Number & ": " & Left$(Err.Description, 60)
    gErrTotal = gErrTotal + 1
    If InStr(gErrList, key) = 0 And Len(gErrList) < 3000 Then
        gErrList = gErrList & key & vbLf
        Stp "NG " & key
    End If
    Err.Clear
End Sub

Public Function ErrSummary() As String
    ErrSummary = "エラー総数=" & gErrTotal & vbLf & gErrList & "ログ=" & gLogPath
End Function

Public Sub InitLabels()
    '位置の手がかりとして伏せ字にしない語（長い語を先に）
    gLabels = Array("郵便番号", "都道府県", "市区町村", "建物名", "会社名", "法人名", _
                    "代表者", "担当者", "フリガナ", "氏名", "名前", "住所", "電話", _
                    "部署", "役職", "宛名", "送付先", "名義", "本人", "個人", "法人", _
                    "御中", "様", "〒")
End Sub

Public Function Mask(ByVal s As String) As String
    Dim i As Long, c As Long, ch As String, out As String
    s = Replace(Replace(Replace(s, vbCr, " "), vbLf, " "), vbTab, " ")
    For i = 0 To UBound(gLabels)
        s = Replace(s, gLabels(i), ChrW(&HE000& + i))
    Next
    For i = 1 To Len(s)
        ch = Mid$(s, i, 1)
        c = AscW(ch): If c < 0 Then c = c + 65536
        If c >= &HE000& And c <= &HE0FF& Then
            out = out & ch
        ElseIf c = 32 Or c = 160 Then
            out = out & "_"
        ElseIf c >= 48 And c <= 57 Then
            out = out & "9"
        ElseIf c >= 65 And c <= 90 Then
            out = out & "A"
        ElseIf c >= 97 And c <= 122 Then
            out = out & "a"
        ElseIf c < 128 Then
            out = out & ch
        Else
            out = out & JpMap(c, ch, False)
        End If
    Next
    For i = 0 To UBound(gLabels)
        out = Replace(out, ChrW(&HE000& + i), gLabels(i))
    Next
    Mask = out
End Function

Public Function SafeAttr(ByVal s As String) As String
    'id/class/属性値用: 日本語は伏せ字、5桁以上の数字列は桁数だけ残す
    Dim i As Long, c As Long, ch As String, out As String, dg As String
    For i = 1 To Len(s)
        ch = Mid$(s, i, 1)
        c = AscW(ch): If c < 0 Then c = c + 65536
        If c >= 48 And c <= 57 Then
            dg = dg & ch
        Else
            If Len(dg) >= 5 Then out = out & "[数字" & Len(dg) & "桁]" Else out = out & dg
            dg = ""
            If c > 127 Then out = out & JpMap(c, ch, True) Else out = out & ch
        End If
    Next
    If Len(dg) >= 5 Then out = out & "[数字" & Len(dg) & "桁]" Else out = out & dg
    SafeAttr = out
End Function

Private Function JpMap(ByVal c As Long, ByVal ch As String, ByVal keepOther As Boolean) As String
    Select Case c
        Case &HFF10& To &HFF19&: JpMap = "９"
        Case &HFF21& To &HFF3A&: JpMap = "Ａ"
        Case &HFF41& To &HFF5A&: JpMap = "ａ"
        Case &H3000&: JpMap = "□"
        Case &H3041& To &H309F&: JpMap = "あ"
        Case &H30FB&: JpMap = ch
        Case &H30A0& To &H30FF&, &HFF66& To &HFF9F&: JpMap = "ア"
        Case &H3400& To &H9FFF&, &H3005&, &H3006&: JpMap = "漢"
        Case &HFF0D&, &H2010& To &H2015&, &H2212&, &HFF1A&, &HFF08&, &HFF09&, _
             &H3012&, &H3001&, &H3002&, &HFF0F&, &HFF0C&, &HFF0E&: JpMap = ch
        Case Else
            If keepOther Then JpMap = ch Else JpMap = "●"
    End Select
End Function

Private Function CodeLike(ByVal s As String) As Boolean
    'c1 / a23 / ab123 のような「英字1-2文字+数字」型か
    Dim i As Long
    If Len(s) = 0 Or Len(s) > 6 Then Exit Function
    i = Len(s)
    Do While i > 0
        If Mid$(s, i, 1) Like "[0-9]" Then i = i - 1 Else Exit Do
    Loop
    CodeLike = (Len(s) - i >= 1 And i <= 2)
End Function

'---------------------------------------------------------------
#If VBA7 Then
Private Function EnumProc(ByVal hWnd As LongPtr, ByVal lParam As LongPtr) As Long
    Dim cls As String, ttl As String, n As Long
    EnumProc = 1
    If IsWindowVisible(hWnd) = 0 Then Exit Function
    cls = String$(256, vbNullChar)
    n = GetClassNameW(hWnd, StrPtr(cls), 256)
    cls = Left$(cls, n)
    If cls = "Chrome_WidgetWin_1" Or cls = "IEFrame" Then
        ttl = String$(512, vbNullChar)
        n = GetWindowTextW(hWnd, StrPtr(ttl), 512)
        ttl = Left$(ttl, n)
        If Len(ttl) > 0 Then
            If cls = "IEFrame" Or InStr(ttl, "Edge") > 0 Then
                gWinList = gWinList & cls & vbTab & ttl & vbLf
            Else
                gChromeOther = gChromeOther + 1
            End If
        End If
    End If
End Function
#End If

Private Sub SPut(ByVal a As String, Optional ByVal b As String = "", Optional ByVal c As String = "")
    gSum.Cells(gSumR, 1).Value = a
    gSum.Cells(gSumR, 2).Value = b
    gSum.Cells(gSumR, 3).Value = c
    If Left$(a, 1) = "■" Then gSum.Cells(gSumR, 1).Font.Bold = True
    gSumR = gSumR + 1
End Sub

'---------------------------------------------------------------
Private Sub DumpDoc(ByVal doc As Object, ByVal lbl As String, ByVal level As Long)
    Dim frames As New Collection
    Dim t As String, u As String, dm As String, cm As String, cs As String, rs As String
    Dim nIf As Long, nFr As Long, startN As Long, i As Long, myNo As Long
    Dim fr As Object, subDoc As Object, fn As String, fs As String

    On Error Resume Next
    gDocs = gDocs + 1
    myNo = gDocs
    startN = gN
    t = doc.Title
    ErrNote "doc.Title"
    u = Split(doc.URL & "?", "?")(0)
    ErrNote "doc.URL"
    dm = doc.documentMode & ""
    ErrNote "doc.documentMode"
    cm = doc.compatMode & ""
    ErrNote "doc.compatMode"
    cs = doc.CharSet & ""
    rs = doc.readyState & ""
    ErrNote "doc.CharSet/readyState"
    nIf = doc.getElementsByTagName("iframe").Length
    nFr = doc.getElementsByTagName("frame").Length
    ErrNote "doc.getElementsByTagName"

    SPut "■文書 " & lbl
    SPut "タイトル", t
    SPut "URL(?より前)", u
    SPut "documentMode / compatMode", dm & " / " & cm, "charset=" & cs & " readyState=" & rs
    SPut "iframe数 / frame数", nIf & " / " & nFr

    Walk doc.documentElement, 0, "html", myNo, frames
    SPut "取得要素行数", CStr(gN - startN)

    If level < 4 Then
        For i = 1 To frames.Count
            Set fr = frames(i)
            fn = "": fs = ""
            fn = SafeAttr(fr.getAttribute("name") & "")
            fs = SafeAttr(Split(fr.getAttribute("src") & "?", "?")(0))
            Set subDoc = Nothing
            Set subDoc = fr.contentWindow.Document
            ErrNote "frame.contentWindow.Document(別ドメイン等で取得不可)"
            If subDoc Is Nothing Then
                SPut "  frame" & i & " 中身を取得できません", "name=" & fn, "src=" & fs
            Else
                SPut "  frame" & i & " を取得", "name=" & fn, "src=" & fs
                DumpDoc subDoc, lbl & "-F" & i, level + 1
            End If
        Next
    End If
End Sub

Private Sub Walk(ByVal el As Object, ByVal depth As Long, ByVal path As String, _
                 ByVal docNo As Long, ByVal frames As Collection)
    Dim kids As Object, nd As Object, cnt As Long, i As Long, k As Long, tp As Long
    Dim own As String, cmt As String, tg As String, parts() As String, p As Long

    If gN >= MAX_ROWS Then Exit Sub
    On Error Resume Next
    Set kids = el.childNodes
    cnt = kids.Length
    ErrNote "childNodes/Length"
    For i = 0 To cnt - 1
        Set nd = Nothing
        Set nd = kids.Item(i)
        If Not nd Is Nothing Then
            tp = 0
            tp = nd.nodeType
            ErrNote "nodeType"
            If tp = 3 Then
                own = own & " " & nd.nodeValue
            ElseIf tp = 8 Then
                cmt = cmt & Chr(1) & Left$(nd.nodeValue & "", 300)
            End If
        End If
    Next

    tg = ""
    tg = UCase$(el.tagName & "")
    ErrNote "tagName"
    AddRow el, depth, path, docNo, own
    If tg = "IFRAME" Or tg = "FRAME" Then frames.Add el
    If Len(cmt) > 0 Then
        parts = Split(cmt, Chr(1))
        For p = 1 To UBound(parts)
            AddCmt parts(p), depth, path, docNo
        Next
    End If

    If tg = "SCRIPT" Or tg = "STYLE" Or tg = "SELECT" Then Exit Sub

    k = 0
    For i = 0 To cnt - 1
        Set nd = Nothing
        Set nd = kids.Item(i)
        If Not nd Is Nothing Then
            tp = 0
            tp = nd.nodeType
            If tp = 1 Then
                k = k + 1
                Walk nd, depth + 1, path & ">" & LCase$(nd.tagName & "") & "[" & k & "]", docNo, frames
            End If
        End If
    Next
End Sub

Private Sub AddRow(ByVal el As Object, ByVal depth As Long, ByVal path As String, _
                   ByVal docNo As Long, ByVal own As String)
    Dim tg As String, id As String, cl As String, nm As String, ty As String
    Dim hid As String, oth As String, txt As String, v As String
    Dim dispS As String, visS As String, an As String, av As String
    Dim a As Object, i As Long, na As Long, si As Long, ow As Long, oh As Long
    Dim spec As Boolean, parts() As String, p As Variant

    If gN >= MAX_ROWS Then Exit Sub
    On Error Resume Next
    tg = UCase$(el.tagName & "")
    ErrNote "el.tagName"
    id = el.ID & ""
    ErrNote "el.ID"
    cl = el.className & ""
    ErrNote "el.className"
    nm = el.getAttribute("name") & ""
    ty = LCase$(el.getAttribute("type") & "")
    ErrNote "el.getAttribute"
    dispS = el.currentStyle.display & ""
    visS = el.currentStyle.visibility & ""
    ErrNote "el.currentStyle"
    ow = -1: ow = el.offsetWidth
    oh = -1: oh = el.offsetHeight
    ErrNote "el.offsetWidth/Height"

    If ty = "hidden" Then
        hid = "hiddenInput"
        gHidInput = gHidInput + 1
        v = "": v = el.Value & ""
        If Len(gHidList) < 4000 Then
            gHidList = gHidList & SafeAttr(nm) & "/" & SafeAttr(id) & "=" & Left$(Mask(v), 30) & vbLf
        End If
    End If
    If dispS = "none" Then
        hid = Trim$(hid & " none")
        gHidNone = gHidNone + 1
    End If
    If visS = "hidden" Then hid = Trim$(hid & " vhidden")
    If ow = 0 And oh = 0 Then
        hid = Trim$(hid & " size0")
        gHidZero = gHidZero + 1
    End If

    own = Replace(Replace(Replace(Replace(own, vbCr, " "), vbLf, " "), vbTab, " "), ChrW(160), " ")
    Do While InStr(own, "  ") > 0
        own = Replace(own, "  ", " ")
    Loop
    txt = Trim$(own)
    If tg = "SCRIPT" Or tg = "STYLE" Then
        txt = "[" & Len(txt) & "文字]"
    Else
        If Len(txt) > 0 Then txt = Left$(Mask(txt), 200)
        If tg = "INPUT" Or tg = "TEXTAREA" Then
            v = "": v = el.Value & ""
            If Len(v) > 0 And ty <> "hidden" Then txt = Trim$("[v]" & Left$(Mask(v), 120) & " " & txt)
        ElseIf tg = "SELECT" Then
            si = -1: si = el.selectedIndex
            oth = "options=" & el.Options.Length & "; "
            If si >= 0 Then
                v = "": v = el.Options(si).Text & ""
                txt = Trim$("[sel]" & Left$(Mask(v), 80) & " " & txt)
            End If
        End If
    End If

    na = -1: na = el.Attributes.Length
    ErrNote "el.Attributes"
    For i = 0 To na - 1
        Set a = Nothing
        Set a = el.Attributes.Item(i)
        If Not a Is Nothing Then
            spec = False: spec = a.specified
            If spec Then
                an = LCase$(a.nodeName & "")
                av = a.nodeValue & ""
                Select Case an
                    Case "id", "class", "name", "type", "style", "value"
                    Case "href", "src"
                        oth = oth & an & "=" & Left$(SafeAttr(Split(av & "?", "?")(0)), 50) & "; "
                    Case "title", "alt", "placeholder", "aria-label"
                        oth = oth & an & "=" & Left$(Mask(av), 40) & "; "
                    Case Else
                        oth = oth & an & "=" & Left$(SafeAttr(av), 40) & "; "
                End Select
            End If
        End If
    Next

    gN = gN + 1
    gData(gN, 1) = gN
    gData(gN, 2) = docNo
    gData(gN, 3) = depth
    gData(gN, 4) = tg
    gData(gN, 5) = SafeAttr(id)
    gData(gN, 6) = SafeAttr(cl)
    gData(gN, 7) = SafeAttr(nm)
    gData(gN, 8) = ty
    gData(gN, 9) = hid
    gData(gN, 10) = txt
    gData(gN, 11) = Len(own)
    gData(gN, 12) = oth
    gData(gN, 13) = path

    gElN = gElN + 1
    If Len(id) > 0 Then
        gIdN = gIdN + 1
        If gIdDup.Exists(id) Then
            gIdDup(id) = gIdDup(id) + 1
        Else
            gIdDup.Add id, 1
        End If
        If CodeLike(id) Then gIdShort = gIdShort + 1
    End If
    If Len(cl) > 0 Then
        parts = Split(Trim$(cl), " ")
        For Each p In parts
            If Len(p) > 0 Then
                If gClsCnt.Exists(p) Then
                    gClsCnt(p) = gClsCnt(p) + 1
                Else
                    gClsCnt.Add p, 1
                End If
            End If
        Next
    End If
End Sub

Private Sub AddCmt(ByVal s As String, ByVal depth As Long, ByVal path As String, ByVal docNo As Long)
    If gN >= MAX_ROWS Then Exit Sub
    gN = gN + 1
    gCmtN = gCmtN + 1
    gData(gN, 1) = gN
    gData(gN, 2) = docNo
    gData(gN, 3) = depth + 1
    gData(gN, 4) = "#COMMENT"
    gData(gN, 10) = Left$(Mask(s), 200)
    gData(gN, 11) = Len(s)
    gData(gN, 13) = path & ">#comment"
End Sub

Private Function IsKey(ByVal i As Long) As Boolean
    Dim tg As String
    tg = gData(i, 4)
    IsKey = (Len(gData(i, 10)) > 0) Or (Len(gData(i, 5)) > 0) Or _
            tg = "INPUT" Or tg = "SELECT" Or tg = "TEXTAREA" Or tg = "IFRAME" Or _
            tg = "FRAME" Or tg = "BUTTON" Or tg = "LABEL" Or tg = "TABLE" Or _
            tg = "TH" Or tg = "#COMMENT"
End Function

'---------------------------------------------------------------
Private Sub SumTail()
    Dim k As Variant, best As String, bc As Long, i As Long, dupN As Long
    Dim lines() As String
    SPut "■DOM統計(全文書の合計)"
    SPut "文書数(frame含む)", CStr(gDocs)
    SPut "取得した要素行数", CStr(gN), IIf(gN >= MAX_ROWS, "上限到達(途中まで)", "")
    SPut "id付き要素数", CStr(gIdN), "idの種類数=" & gIdDup.Count
    For Each k In gIdDup.Keys
        If gIdDup(k) > 1 Then dupN = dupN + 1
    Next
    SPut "重複しているid数", CStr(dupN)
    SPut "idが英字1-2文字+数字型(c1,a23風)", CStr(gIdShort), "id付き要素のうちの件数"
    SPut "classの種類数", CStr(gClsCnt.Count)
    SPut "非表示 hiddenInput / display:none / サイズ0", gHidInput & " / " & gHidNone & " / " & gHidZero
    SPut "HTMLコメント数", CStr(gCmtN)
    SPut "■class使用頻度 上位20", "出現数"
    For i = 1 To 20
        best = "": bc = 0
        For Each k In gClsCnt.Keys
            If gClsCnt(k) > bc Then
                bc = gClsCnt(k)
                best = CStr(k)
            End If
        Next
        If bc = 0 Then Exit For
        SPut SafeAttr(best), CStr(bc)
        gClsCnt(best) = -bc
    Next
    If Len(gHidList) > 0 Then
        SPut "■hidden input (name/id=値の伏せ字)"
        lines = Split(gHidList, vbLf)
        For i = 0 To UBound(lines)
            If Len(lines(i)) > 0 And i < 40 Then SPut lines(i)
        Next
    End If
    SPut "■読み取りエラー記録(種類ごと。Err番号と内容)"
    SPut "エラー総数", CStr(gErrTotal), "要素の種類により出る正常な失敗も含む"
    If Len(gErrList) > 0 Then
        lines = Split(gErrList, vbLf)
        For i = 0 To UBound(lines)
            If Len(lines(i)) > 0 Then SPut lines(i)
        Next
    End If
    SPut "ステップログ(最後の行=最後に開始した処理)", gLogPath
End Sub

Private Sub WriteLabelCtx(ByVal ws As Worksheet)
    Dim idx() As Long, m As Long, i As Long, pos As Long, j As Long, r As Long
    Dim t As String, lb As Variant, hitLb As String, shown As Object
    Dim a As Long, b As Long, kind As String

    ws.Range("A:J").NumberFormat = "@"
    ws.Range("A1:J1").Value = Array("区分", "連番", "文書", "深さ", "タグ", "id", "class", "非表示", "テキスト(伏せ字)", "パス")
    r = 2
    ReDim idx(1 To gN + 1)
    For i = 1 To gN
        If Len(gData(i, 10)) > 0 Then
            Select Case gData(i, 4)
                Case "#COMMENT", "SCRIPT", "STYLE"
                Case Else
                    m = m + 1
                    idx(m) = i
            End Select
        End If
    Next
    Set shown = CreateObject("Scripting.Dictionary")
    For pos = 1 To m
        t = gData(idx(pos), 10)
        hitLb = ""
        For Each lb In gLabels
            If InStr(t, lb) > 0 Then
                hitLb = lb
                Exit For
            End If
        Next
        If hitLb <> "" Then
            If Not shown.Exists(hitLb) Then shown.Add hitLb, 0
            If shown(hitLb) < 3 Then
                shown(hitLb) = shown(hitLb) + 1
                a = pos - 1: If a < 1 Then a = 1
                b = pos + 3: If b > m Then b = m
                For j = a To b
                    If j < pos Then
                        kind = "前"
                    ElseIf j = pos Then
                        kind = "【" & hitLb & "】"
                    Else
                        kind = "次" & (j - pos)
                    End If
                    PutRow ws, r, kind, idx(j)
                    r = r + 1
                Next
                r = r + 1
            End If
        End If
    Next
    If r = 2 Then ws.Range("A2").Value = "ラベル語を含む行が見つかりませんでした"
End Sub

Private Sub PutRow(ByVal ws As Worksheet, ByVal r As Long, ByVal kind As String, ByVal i As Long)
    ws.Cells(r, 1).Value = kind
    ws.Cells(r, 2).Value = gData(i, 1)
    ws.Cells(r, 3).Value = gData(i, 2)
    ws.Cells(r, 4).Value = gData(i, 3)
    ws.Cells(r, 5).Value = gData(i, 4)
    ws.Cells(r, 6).Value = gData(i, 5)
    ws.Cells(r, 7).Value = gData(i, 6)
    ws.Cells(r, 8).Value = gData(i, 9)
    ws.Cells(r, 9).Value = gData(i, 10)
    ws.Cells(r, 10).Value = gData(i, 13)
End Sub

Private Function WriteDom(ByVal ws As Worksheet) As Long
    Dim tmp() As Variant, i As Long, c As Long, nKey As Long
    If gN = 0 Then
        ws.Range("A1").Value = "要素なし（HTMLDocumentが取得できませんでした）"
        Exit Function
    End If
    ReDim tmp(1 To gN, 1 To COLS)
    For i = 1 To gN
        For c = 1 To 13
            tmp(i, c) = gData(i, c)
        Next
        If IsKey(i) Then
            tmp(i, 14) = 1
            nKey = nKey + 1
        Else
            tmp(i, 14) = 0
        End If
    Next
    ws.Range("D:J,L:M").NumberFormat = "@"
    ws.Range("A1").Resize(1, COLS).Value = Array("連番", "文書", "深さ", "タグ", "id", "class", "name", "type", _
        "非表示", "直下テキスト(伏せ字)", "直下文字数", "その他属性", "パス", "要点")
    ws.Range("A2").Resize(gN, COLS).Value = tmp
    ws.Range("A1").Resize(gN + 1, COLS).AutoFilter Field:=14, Criteria1:="1"
    WriteDom = nKey
End Function

Private Sub FmtSheet(ByVal ws As Worksheet, ByVal fs As Double, ByVal land As Boolean, ByVal titleRows As String)
    On Error Resume Next
    ws.Cells.Font.Size = fs
    With ws.PageSetup
        If land Then
            .Orientation = xlLandscape
        Else
            .Orientation = xlPortrait
        End If
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .LeftHeader = "&D &T"
        .CenterFooter = "&P / &N"
        If Len(titleRows) > 0 Then .PrintTitleRows = titleRows
    End With
End Sub

Private Sub SetWidths(ByVal ws As Worksheet, ByVal w As Variant)
    Dim i As Long
    For i = 0 To UBound(w)
        ws.Columns(i + 1).ColumnWidth = w(i)
    Next
End Sub

'---------------------------------------------------------------
Private Sub ExtCheck()
    'PowerShell起動可否とデバッグポート(9222)の応答確認
    Dim sh As Object, ex As Object, t As Single, s As String, http As Object
    SPut "■拡張確認(PowerShell / デバッグポート)"
    On Error Resume Next
    Set sh = CreateObject("WScript.Shell")
    Set ex = sh.Exec("powershell -NoProfile -NonInteractive -Command ""$PSVersionTable.PSVersion.ToString(); $ExecutionContext.SessionState.LanguageMode""")
    If Err.Number <> 0 Then
        SPut "PowerShell", "起動不可", Err.Description
        Err.Clear
    Else
        t = Timer
        Do While ex.Status = 0 And Timer - t < 15
            DoEvents
        Loop
        s = Replace(ex.StdOut.ReadAll, vbCrLf, " / ")
        SPut "PowerShell(版 / 言語モード)", s
    End If
    Err.Clear
    Set http = CreateObject("MSXML2.ServerXMLHTTP.6.0")
    http.setTimeouts 2000, 2000, 2000, 2000
    http.Open "GET", "http://127.0.0.1:9222/json/version", False
    http.send
    If Err.Number <> 0 Then
        SPut "デバッグポート9222", "応答なし(Edgeは通常起動)"
        Err.Clear
    Else
        SPut "デバッグポート9222", http.Status & " " & Left$(http.responseText, 100)
    End If
End Sub

————————————————————————————————————————————————————————————

Option Explicit
'================================================================
' DiagUia : UI Automation診断（IEモードでDOMが取れない場合用）
'  事前準備:
'   1) VBEの「ツール > 参照設定」で「UIAutomationClient」にチェック
'      （Windows標準のライブラリ。インストール不要）
'   2) DiagDom も標準モジュールとして貼り付けておく
'      （InitLabels / Mask / SafeAttr を共用します）
'  実行: 新システムの画面をEdgeで開いたまま「UIA診断」を実行
'  出力: 文字は伏せ字化（ラベル語のみ元のまま）。画面全体ではなく
'        Edge内の画面(Document)以下だけを調べます。
'================================================================
Private Const MAX_N As Long = 20000

Public Sub UIA診断()
    Dim uia As New CUIAutomation
    Dim root As IUIAutomationElement, wins As IUIAutomationElementArray
    Dim tgt As IUIAutomationElement, docEl As IUIAutomationElement, el As IUIAutomationElement
    Dim arr As IUIAutomationElementArray, cond As IUIAutomationCondition
    Dim vp As IUIAutomationValuePattern, rc As tagRECT
    Dim kw As String, nm As String, ttl As String, v As String, tl As String, tys As String
    Dim i As Long, n As Long, tries As Long, r As Long, nKey As Long, nId As Long, ct As Long, c As Long
    Dim ws As Worksheet, out() As Variant, tmp() As Variant, tyCnt As Object, k As Variant
    Dim pg As Long

    StpReset
    Stp "UIA診断開始"
    InitLabels
    kw = InputBox("対象Edge画面のタイトルの一部を入力してください。" & vbLf & _
                  "空欄の場合は最初に見つかったEdgeウィンドウを調べます。", "UIA診断")

    '--- Edgeウィンドウを探す
    Stp "UIA: CUIAutomation生成とルート取得"
    Set root = uia.GetRootElement
    Stp "UIA: トップレベルウィンドウ列挙(FindAll)"
    Set wins = root.FindAll(2, uia.CreateTrueCondition)          'TreeScope_Children
    Stp "UIA: Edgeウィンドウ探索(" & wins.Length & "件中)"
    For i = 0 To wins.Length - 1
        Set el = wins.GetElement(i)
        If el.CurrentClassName = "Chrome_WidgetWin_1" Then
            nm = el.CurrentName
            If InStr(nm, "Edge") > 0 And (kw = "" Or InStr(nm, kw) > 0) Then
                Set tgt = el
                ttl = nm
                Exit For
            End If
        End If
    Next
    If tgt Is Nothing Then
        Stp "NG: Edgeウィンドウが見つからない"
        Application.StatusBar = False
        MsgBox "Edgeウィンドウが見つかりません。", vbExclamation
        Exit Sub
    End If

    '--- 画面内容(Document)を探す（Edgeは最初の接続で準備するため数回リトライ）
    Stp "UIA: Document要素を探索(FindFirst)"
    Set cond = uia.CreatePropertyCondition(30003, 50030)          'ControlType = Document
    For tries = 1 To 5
        Set docEl = Nothing
        On Error Resume Next
        Set docEl = tgt.FindFirst(4, cond)                        'TreeScope_Descendants
        On Error GoTo 0
        If Not docEl Is Nothing Then Exit For
        Application.Wait Now + TimeSerial(0, 0, 2)
    Next
    If docEl Is Nothing Then
        Stp "NG: Document要素が見つからない"
        Application.StatusBar = False
        MsgBox "画面内容(Document)を取得できません。", vbExclamation
        Exit Sub
    End If

    '--- 全要素を取得
    Stp "UIA: 全要素取得(FindAll。時間がかかる場合あり)"
    Application.StatusBar = "UIA要素を取得中…（数十秒かかることがあります）"
    Set arr = docEl.FindAll(4, uia.CreateTrueCondition)
    n = arr.Length
    If n > MAX_N Then n = MAX_N
    ReDim out(1 To IIf(n > 0, n, 1), 1 To 13)
    Set tyCnt = CreateObject("Scripting.Dictionary")

    On Error Resume Next
    For i = 0 To n - 1
        Set el = Nothing
        Set el = arr.GetElement(i)
        ErrNote "UIA GetElement"
        If Not el Is Nothing Then
            r = r + 1
            tl = "": tl = el.CurrentLocalizedControlType
            ct = 0: ct = el.CurrentControlType
            ErrNote "UIA LocalizedControlType/ControlType"
            out(r, 1) = r
            out(r, 2) = tl
            out(r, 3) = ct
            out(r, 4) = SafeAttr(el.CurrentAutomationId & "")
            out(r, 5) = SafeAttr(el.CurrentClassName & "")
            ErrNote "UIA AutomationId/ClassName"
            nm = "": nm = el.CurrentName
            ErrNote "UIA Name"
            If Len(nm) > 0 Then out(r, 6) = Left$(Mask(nm), 200)
            Set vp = Nothing
            Set vp = el.GetCurrentPattern(10002)                  'ValuePattern
            v = ""
            If Not vp Is Nothing Then v = vp.CurrentValue
            ErrNote "UIA ValuePattern"
            If Len(v) > 0 Then out(r, 7) = Left$(Mask(v), 120)
            If el.CurrentIsOffscreen <> 0 Then out(r, 8) = "画面外"
            rc = el.CurrentBoundingRectangle
            ErrNote "UIA BoundingRectangle"
            out(r, 9) = rc.Left
            out(r, 10) = rc.Top
            out(r, 11) = rc.Right - rc.Left
            out(r, 12) = rc.Bottom - rc.Top

            If Len(out(r, 4)) > 0 Then nId = nId + 1
            If tyCnt.Exists(tl) Then
                tyCnt(tl) = tyCnt(tl) + 1
            Else
                tyCnt.Add tl, 1
            End If
            If Len(out(r, 6)) > 0 Or Len(out(r, 7)) > 0 Or Len(out(r, 4)) > 0 Or _
               ct = 50004 Or ct = 50003 Or ct = 50000 Or ct = 50005 Or ct = 50002 Or ct = 50013 Then
                out(r, 13) = 1
                nKey = nKey + 1
            Else
                out(r, 13) = 0
            End If
        End If
        If i Mod 200 = 0 Then
            Application.StatusBar = "UIA " & i & " / " & n
            DoEvents
        End If
    Next
    On Error GoTo 0
    Application.StatusBar = False

    '--- シートへ出力
    Stp "UIA: シート出力(" & r & "件)"
    Set ws = ThisWorkbook.Worksheets.Add
    ws.Name = "UIA" & Format(Now, "mmdd_hhnn")
    ws.Cells.NumberFormat = "@"
    ws.Range("A1").Value = "UIA診断 " & Format(Now, "yyyy/mm/dd hh:nn")
    ws.Range("A2").Value = "Edge画面名"
    ws.Range("B2").Value = ttl
    ws.Range("A3").Value = "取得要素数"
    ws.Range("B3").Value = CStr(r) & IIf(arr.Length > MAX_N, " (上限で打切り)", "")
    ws.Range("A4").Value = "AutomationIdあり"
    ws.Range("B4").Value = CStr(nId)
    For Each k In tyCnt.Keys
        tys = tys & k & "=" & tyCnt(k) & " / "
    Next
    ws.Range("A5").Value = "種類別件数"
    ws.Range("B5").Value = tys
    ws.Range("A6").Value = "読取エラー/ログ"
    ws.Range("B6").Value = ErrSummary()
    ws.Range("B6").WrapText = True
    ws.Range("A7").Resize(1, 13).Value = Array("連番", "種類", "型番号", "AutomationId", "ClassName", _
        "名前(伏せ字)", "値(伏せ字)", "画面外", "左", "上", "幅", "高さ", "要点")
    If r > 0 Then
        ReDim tmp(1 To r, 1 To 13)
        For i = 1 To r
            For c = 1 To 13
                tmp(i, c) = out(i, c)
            Next
        Next
        ws.Range("A8").Resize(r, 13).Value = tmp
        ws.Range("A7").Resize(r + 1, 13).AutoFilter Field:=13, Criteria1:="1"
    End If

    ws.Cells.Font.Size = 8
    ws.Columns("B5").WrapText = True
    ws.Columns(1).ColumnWidth = 18
    ws.Columns(2).ColumnWidth = 14
    ws.Columns(3).ColumnWidth = 7
    ws.Columns(4).ColumnWidth = 22
    ws.Columns(5).ColumnWidth = 24
    ws.Columns(6).ColumnWidth = 44
    ws.Columns(7).ColumnWidth = 30
    ws.Columns(8).ColumnWidth = 7
    For c = 9 To 13
        ws.Columns(c).ColumnWidth = 6
    Next
    On Error Resume Next
    With ws.PageSetup
        .Orientation = xlLandscape
        .Zoom = False
        .FitToPagesWide = 1
        .FitToPagesTall = False
        .LeftHeader = "&D &T"
        .CenterFooter = "&P / &N"
        .PrintTitleRows = "$7:$7"
        .PrintArea = ws.Range("A1").Resize(r + 7, 12).Address
    End With
    On Error GoTo 0

    ws.Activate
    Stp "UIA完了(印刷確認)"
    pg = nKey \ 45 + 1
    If r < 20 Then
        MsgBox "取得できた要素が少ない(" & r & "件)です。" & vbLf & _
               "Edgeは最初のUIA接続で準備するため、もう一度実行すると取れることがあります。", vbInformation
    End If
    If MsgBox("UIAシートができました。印刷しますか？(要点のみ 約" & pg & "ページ)" & vbLf & _
              "※個人情報は伏せ字化していますが、印刷後に目視で確認してください。", _
              vbYesNo + vbQuestion, "UIA診断") = vbYes Then
        Stp "印刷(UIA)"
        ws.PrintOut
    End If
    Stp "完了"
    Application.StatusBar = False
End Sub

remove_excel_protection.ps1

# ==================================================================
# Excel(.xlsm) 保護解除スクリプト
#   ① ブック構成の保護・書き込みパスワード  ② シートの保護  ③ VBAプロジェクトのロック
#
# 使い方: Excelを閉じる → 下の「書き換え箇所」を直す → 全体をPowerShellに貼り付けて実行
#         （対象ファイルのあるフォルダのアドレスバーに powershell と入力して開いた画面でOK）
#
# 流れ:
#   【事前チェック】読み取りだけで、問題を「全部」洗い出す（途中で止まらない）
#        └ 環境やファイル自体の問題があれば、一覧を出して終了（ファイルは一切変更しない）
#        └ 特定のシート等だけの問題なら、$skipFailedItems = $true で、その項目だけスキップして続行
#   【実行】問題がなければ、作業用コピーを加工 → 作業用コピーの保存まで成功したときだけ元ファイルを上書き
#        └ 実行前に「元ファイル名.日時.bak」も作る（再実行しても過去のバックアップは上書きしない）
#   実行ログは、対象ファイルと同じフォルダに protection_log_日時.txt として保存される
#
# 実行後の流れ（想定）:
#   1. Shiftを押しながらファイルを開く（起動時マクロが保護をかけ直すのを防ぐ）
#   2. Alt+F11 > VBAProject右クリック > プロパティ > 保護 で、ロックを外す／新パスワードを設定
#      （Excelの読み込み警告は「はい/OK」で進める）
#   3. 保存して閉じ、開き直して デバッグ > VBAProjectのコンパイル
#   4. modVbaScan.bas で PtrSafe不足・参照設定・固定パスなどを一括確認して修正
#   5. Shiftなしで通常どおり開いて動作確認
#   元に戻したいとき: 「元ファイル名.日時.bak」を元のファイル名にコピーして戻す
# ==================================================================

# ##################################################################
# ★★★★★  書き換えるのはここだけ  ここから  ★★★★★
# ##################################################################
# 【必須】対象ファイル。フルパス、またはファイル名だけ（例 "BookA.xlsm"）でも可
#        ファイル名だけの場合は、PowerShellを開いたフォルダ基準になります
$src = "C:\work\BookA_copy.xlsm"

# 【任意】$true にすると「事前チェックだけ」して終了（ファイルは一切変更しない）
#        $false なら、事前チェックで問題がなかったときに続けて実行まで行う
$checkOnly = $false

# 【任意】$true なら、一部の項目（特定のシートなど）に問題があっても、実行できる項目だけ実行する。
#        できなかった項目はスキップして結果に表示する（その保護は残る）
#        $false なら、1つでも問題があれば何も実行しない
$skipFailedItems = $true
# ##################################################################
# ★★★★★  書き換えるのはここだけ  ここまで（これより下は触らない）  ★★★★★
# ##################################################################

& {
    $line = "=" * 64
    $bak  = ''
    $work = ''
    $zip  = $null

    # ---- 手順名（まとめ表示の順番にも使う）----
    $K1 = 'チェック1: PowerShell実行環境'
    $K2 = 'チェック2: 対象ファイル'
    $K3 = 'チェック3: 書き込み可否'
    $K4 = 'チェック4: ディスク空き容量'
    $K5 = 'チェック5: ZIPとして開けるか'
    $S1 = '① ブック構成の保護・書き込みパスワード'
    $S2 = '② シートの保護'
    $S3 = '③ VBAプロジェクトのロック'
    $A1 = '実行1: バックアップ作成'
    $A2 = '実行2: 作業用コピーを書き込みモードで開く'
    $A3 = '実行3: 作業用コピーの保存'
    $A4 = '実行4: 元ファイルへの反映'
    $planCheck = @($K1, $K2, $K3, $K4, $K5, $S1, $S2, $S3)
    $planApply = @($A1, $A2, $S1, $S2, $S3, $A3, $A4)

    $resCheck = New-Object System.Collections.ArrayList
    $resApply = New-Object System.Collections.ArrayList
    $state = @{
        Phase = 'CHECK'; Cur = $resCheck; Stop = $false; Problems = 0; Fatal = 0; Writing = $false
        Target = ''; Action = ''; Vba = 'NOTRUN'; Wb = 'NOTRUN'
        Applied = $false; KeepWork = $false
    }
    $sheetInfo = @{}

    # ================= 共通関数 =================
    function Get-Mark($status) {
        if ($state.Phase -eq 'CHECK') {
            switch ($status) {
                'OK'     { return @{ Mark = '[OK]';       Color = 'Green' } }
                'SKIP'   { return @{ Mark = '[対象なし]'; Color = 'Gray' } }
                'WARN'   { return @{ Mark = '[注意]';     Color = 'Yellow' } }
                'NOTRUN' { return @{ Mark = '[確認不可]'; Color = 'DarkYellow' } }
                default  { return @{ Mark = '[問題あり]'; Color = 'Red' } }
            }
        } else {
            switch ($status) {
                'OK'     { return @{ Mark = '[成功]';     Color = 'Green' } }
                'SKIP'   { return @{ Mark = '[対象なし]'; Color = 'Gray' } }
                'WARN'   { return @{ Mark = '[注意]';     Color = 'Yellow' } }
                'NOTRUN' { return @{ Mark = '[未実行]';   Color = 'DarkYellow' } }
                default  { return @{ Mark = '[失敗]';     Color = 'Red' } }
            }
        }
    }
    function Show-Result($step, $status, $summary, $details) {
        [void]$state.Cur.Add([pscustomobject]@{ Step = $step; Status = $status; Summary = $summary; Details = @($details) })
        $mk = Get-Mark $status
        Write-Host ("  {0} {1} : {2}" -f $mk.Mark, $step, $summary) -ForegroundColor $mk.Color
        foreach ($d in @($details)) {
            if ($d) {
                if ($status -eq 'NG') { Write-Host ("        " + $d) -ForegroundColor Red }
                elseif ($status -eq 'WARN') { Write-Host ("        " + $d) -ForegroundColor Yellow }
                else { Write-Host ("        " + $d) }
            }
        }
    }
    function Set-Ctx($target, $action) { $state.Target = $target; $state.Action = $action }
    function Fail($step, $summary, $reason, $extra) {
        $d = @()
        $d += ("対象            : {0}" -f $state.Target)
        $d += ("しようとした操作: {0}" -f $state.Action)
        $d += ("失敗の理由      : {0}" -f $reason)
        foreach ($x in @($extra)) { if ($x) { $d += $x } }
        $isItem = ($step -eq $S1 -or $step -eq $S2 -or $step -eq $S3)
        if ($state.Phase -eq 'CHECK') {
            $state.Problems++
            if (-not $isItem) { $state.Fatal++ }
            if ($isItem -and $skipFailedItems) {
                $d += "影響            : 実行時にこの項目はスキップされます（他の項目は実行できます）"
            } else {
                $d += "影響            : このままでは実行できません（他の項目のチェックは続けます）"
            }
            Show-Result $step 'NG' $summary $d
        } elseif ($isItem -and $skipFailedItems -and -not $state.Writing) {
            $d += "結果            : この項目はスキップしました（他の項目は続行）。この保護は残っています"
            Show-Result $step 'WARN' ("スキップ: " + $summary) $d
        } else {
            $state.Stop = $true
            $d += "結果            : ここで処理を中止しました（元ファイルは変更していません）"
            Show-Result $step 'NG' $summary $d
        }
    }
    function Mark-NotRun($names, $why) {
        foreach ($n in $names) { Show-Result $n 'NOTRUN' $why @() }
    }
    function Get-TextEntry($entry) {
        $r = New-Object IO.StreamReader($entry.Open(), [Text.Encoding]::UTF8)
        $t = $r.ReadToEnd()
        $r.Close()
        return $t
    }
    function Set-TextEntry($zipObj, $name, $text) {
        $old = $zipObj.GetEntry($name)
        if ($old) { $old.Delete() }
        $new = $zipObj.CreateEntry($name)
        $w = New-Object IO.StreamWriter($new.Open(), (New-Object Text.UTF8Encoding($false)))
        $w.Write($text)
        $w.Close()
    }
    function Find-Bytes($data, $pat) {
        $i = [Array]::IndexOf($data, $pat[0], 0)
        while ($i -ge 0 -and $i -le ($data.Length - $pat.Length)) {
            $ok = $true
            for ($j = 1; $j -lt $pat.Length; $j++) {
                if ($data[$i + $j] -ne $pat[$j]) { $ok = $false; break }
            }
            if ($ok) { return $i }
            $i = [Array]::IndexOf($data, $pat[0], $i + 1)
        }
        return -1
    }
    function Get-SheetLabel($path) {
        $leaf = $path -replace '^xl/', ''
        if ($sheetInfo.ContainsKey($path)) {
            $si = $sheetInfo[$path]
            $vis = ''
            if ($si.State -eq 'hidden') { $vis = ' [非表示]' }
            elseif ($si.State -eq 'veryHidden') { $vis = ' [超非表示]' }
            return ("シート「{0}」({1}){2}" -f $si.Name, $leaf, $vis)
        }
        return ("シート ({0})" -f $leaf)
    }
    # VBAプロジェクト内のモジュール一覧（PROJECTストリームのテキストから取得。失敗しても処理には影響しない）
    function Get-VbaInfo($b) {
        $info = @{ Project = ''; Std = @(); Cls = @(); Doc = @(); Frm = @() }
        try {
            try { $enc = [Text.Encoding]::GetEncoding(932) } catch { $enc = [Text.Encoding]::GetEncoding(28591) }
            $t = $enc.GetString($b)
            $pm = [regex]::Match($t, '(?m)^Name="([^"\r\n]{1,64})"')
            if ($pm.Success) { $info.Project = $pm.Groups[1].Value }
            foreach ($mm in [regex]::Matches($t, '(?m)^(Module|Class|Document|BaseClass)=([^\r\n/]{1,64})')) {
                $kind = $mm.Groups[1].Value
                $nm = $mm.Groups[2].Value
                if ($kind -eq 'Module' -and $info.Std -notcontains $nm) { $info.Std += $nm }
                if ($kind -eq 'Class' -and $info.Cls -notcontains $nm) { $info.Cls += $nm }
                if ($kind -eq 'Document' -and $info.Doc -notcontains $nm) { $info.Doc += $nm }
                if ($kind -eq 'BaseClass' -and $info.Frm -notcontains $nm) { $info.Frm += $nm }
            }
        } catch { }
        return $info
    }
    function Print-Summary($list, $plan, $title) {
        $byName = @{}
        foreach ($r in $list) { $byName[$r.Step] = $r }
        Write-Host ""
        Write-Host $line
        Write-Host $title
        $c = @{ OK = 0; SKIP = 0; WARN = 0; NG = 0; NOTRUN = 0 }
        foreach ($n in $plan) {
            if ($byName.ContainsKey($n)) { $r = $byName[$n] }
            else { $r = [pscustomobject]@{ Step = $n; Status = 'NOTRUN'; Summary = '実施（確認）しませんでした'; Details = @() } }
            $mk = Get-Mark $r.Status
            Write-Host ("  {0} {1} : {2}" -f $mk.Mark, $r.Step, $r.Summary) -ForegroundColor $mk.Color
            if ($r.Status -eq 'NG' -or $r.Status -eq 'WARN') {
                foreach ($d in $r.Details) { Write-Host ("        " + $d) -ForegroundColor $mk.Color }
            }
            $c[$r.Status]++
        }
        Write-Host $line
        if ($state.Phase -eq 'CHECK') {
            Write-Host ("件数: OK {0} / 対象なし {1} / 注意 {2} / 問題あり {3} / 確認不可 {4}" -f $c.OK, $c.SKIP, $c.WARN, $c.NG, $c.NOTRUN)
        } else {
            Write-Host ("件数: 成功 {0} / 対象なし {1} / 注意 {2} / 失敗 {3} / 未実行 {4}" -f $c.OK, $c.SKIP, $c.WARN, $c.NG, $c.NOTRUN)
        }
    }

    # ================= ① ブック構成の保護・書き込みパスワード =================
    function Step-Workbook($apply) {
        Write-Host ""
        Write-Host "【1/3】ブック構成の保護（校閲 > ブックの保護）と、書き込みパスワード（開くときの書き込み権限の確認）"
        try {
            Set-Ctx 'ブック構成 (xl/workbook.xml)' 'ファイルを読み込む'
            $e = $zip.GetEntry('xl/workbook.xml')
            if (-not $e) { Fail $S1 '解除できません' 'xl/workbook.xml がありません（xlsx/xlsm形式ではない可能性）'; return }
            $xml = Get-TextEntry $e
            Set-Ctx 'ブック構成 (xl/workbook.xml)' '保護の記述 <workbookProtection> と <fileSharing> を探す'
            $mWb = [regex]::Match($xml, '<workbookProtection[^>]*/>')
            $mFs = [regex]::Match($xml, '<fileSharing[^>]*/>')
            if (-not $mWb.Success) { if ($apply) { $state.Wb = 'NONE' } }
            if ((-not $mWb.Success) -and (-not $mFs.Success)) {
                Show-Result $S1 'SKIP' '0件（ブック構成の保護も、書き込みパスワードもありません）' @('対象: ブック構成 (xl/workbook.xml)')
                return
            }
            $d = @('対象: ブック構成 (xl/workbook.xml)')
            $cnt = 0
            $newXml = $xml
            if ($mWb.Success) {
                $tag = $mWb.Value
                $d += '[ブック構成の保護] 操作: <workbookProtection> 要素を削除'
                if ($tag -match 'lockStructure="(1|true)"') { $d += '    保護内容: シートの追加・削除・移動・再表示' }
                if ($tag -match 'lockWindows="(1|true)"') { $d += '    保護内容: ウィンドウの位置・サイズ' }
                if ($tag -match 'workbookPassword=|workbookHashValue=') { $d += '    パスワード: あり（記述ごと削除するので入力不要になります）' }
                else { $d += '    パスワード: なし' }
                $newXml = $newXml.Replace($tag, '')
                $cnt++
            }
            if ($mFs.Success) {
                $tag2 = $mFs.Value
                $d += '[書き込みパスワード] 操作: <fileSharing> 要素を削除'
                if ($tag2 -match 'reservationPassword=|hashValue=') { $d += '    パスワード: あり（記述ごと削除するので入力不要になります）' }
                else { $d += '    パスワード: なし' }
                if ($tag2 -match 'readOnlyRecommended="(1|true)"') { $d += '    「読み取り専用を推奨する」設定も同時に外れます' }
                $newXml = $newXml.Replace($tag2, '')
                $cnt++
            }
            if ($apply) {
                Set-Ctx 'ブック構成 (xl/workbook.xml)' '保護の要素を削除して書き戻す'
                $state.Writing = $true
                Set-TextEntry $zip 'xl/workbook.xml' $newXml
                $state.Writing = $false
                if ($mWb.Success) { $state.Wb = 'DONE' }
                Show-Result $S1 'OK' ("{0}件 解除しました" -f $cnt) $d
            } else {
                Show-Result $S1 'OK' ("{0}件 解除できます（解除予定）" -f $cnt) $d
            }
        } catch {
            Fail $S1 '処理中にエラー' $_.Exception.Message
        }
    }

    # ================= ② シートの保護 =================
    function Step-Sheets($apply) {
        Write-Host ""
        Write-Host "【2/3】シートの保護（校閲 > シートの保護）"
        $done = @()
        $none = @()
        $issues = @()
        $cnt = 0
        $total = 0
        try {
            Set-Ctx 'シート一覧 (xl/worksheets, xl/chartsheets)' 'シートのXMLファイルを列挙する'
            $targets = @($zip.Entries | Where-Object {
                $_.FullName -like 'xl/worksheets/sheet*.xml' -or
                $_.FullName -like 'xl/chartsheets/sheet*.xml'
            })
            $total = $targets.Count
            Write-Host ("    検査するシート数: {0} 枚" -f $total)
            foreach ($t in $targets) {
                $path = $t.FullName
                $label = Get-SheetLabel $path
                try {
                    Set-Ctx $label '保護の記述 <sheetProtection> を探すためXMLを読み込む'
                    $x = Get-TextEntry $t
                    $m = [regex]::Match($x, '<sheetProtection[^>]*/>')
                    if (-not $m.Success) { $none += $label; continue }
                    if ($m.Value -match 'password="|hashValue=') { $pw = 'あり' } else { $pw = 'なし' }
                    if ($apply) {
                        Set-Ctx $label '<sheetProtection> 要素を削除して書き戻す'
                        $state.Writing = $true
                        Set-TextEntry $zip $path ($x.Replace($m.Value, ''))
                        $state.Writing = $false
                    }
                    $cnt++
                    $done += ("{0}: {1}  （パスワード: {2}）" -f $(if ($apply) { '解除' } else { '解除予定' }), $label, $pw)
                    if ($apply) { Write-Host ("    解除: {0}" -f $label) -ForegroundColor Green }
                } catch {
                    if ($apply -and ($state.Writing -or -not $skipFailedItems)) { throw }
                    $issues += ("問題: {0} / しようとした操作: {1} / 理由: {2}" -f $state.Target, $state.Action, $_.Exception.Message)
                }
            }
            $summary = ("検査 {0} 枚 / 解除{1} {2} 枚 / 保護なし {3} 枚" -f $total, $(if ($apply) { '' } else { '予定' }), $cnt, $none.Count)
            $d = @()
            $d += $issues
            $d += $done
            if ($none.Count -gt 0) { $d += ("保護なし: " + ($none -join ' / ')) }
            if ($issues.Count -gt 0) {
                if ($apply) {
                    Show-Result $S2 'WARN' ("スキップあり: 解除 {0} 枚 / 解除できず {1} 枚（{2}）" -f $cnt, $issues.Count, $summary) $d
                } else {
                    $state.Problems++
                    Show-Result $S2 'NG' ("問題のあるシート {0} 枚（{1}）" -f $issues.Count, $summary) $d
                }
            }
            elseif ($cnt -gt 0) { Show-Result $S2 'OK' $summary $d }
            else { Show-Result $S2 'SKIP' ("0件（" + $summary + "）") $d }
        } catch {
            $extra = @(("ここまでに解除済み: {0} 枚（作業用コピー内のみ。元ファイルには未反映）" -f $cnt))
            Fail $S2 ("シートの処理に失敗（検査対象 {0} 枚中）" -f $total) $_.Exception.Message $extra
        }
    }

    # ================= ③ VBAプロジェクトのロック =================
    function Step-Vba($apply) {
        Write-Host ""
        Write-Host "【3/3】VBAプロジェクトのロック（DPB= を DPx= に変更）"
        try {
            Set-Ctx 'VBAプロジェクト (xl/vbaProject.bin)' 'ファイルを読み込む'
            $e = $zip.GetEntry('xl/vbaProject.bin')
            if (-not $e) {
                if ($apply) { $state.Vba = 'NOVBA' }
                Show-Result $S3 'SKIP' '0件（vbaProject.bin がありません。マクロなしのファイルです）' @()
                return
            }
            $ms = New-Object IO.MemoryStream
            $s = $e.Open()
            $s.CopyTo($ms)
            $s.Close()
            $b = $ms.ToArray()
            Set-Ctx 'VBAプロジェクト (xl/vbaProject.bin)' 'ロック情報 DPB= を探す'
            $pos = Find-Bytes $b ([byte[]](0x44, 0x50, 0x42, 0x3D))
            if ($pos -lt 0) {
                if ((Find-Bytes $b ([byte[]](0x44, 0x50, 0x78, 0x3D))) -ge 0) {
                    if ($apply) { $state.Vba = 'ALREADY' }
                    Show-Result $S3 'SKIP' '0件（既に DPx= に変更済みです）' @('対象: VBAプロジェクト (xl/vbaProject.bin)')
                } else {
                    if ($apply) { $state.Vba = 'NOLOCK' }
                    Show-Result $S3 'SKIP' '0件（DPB= が見つかりません。ロックなし、または別形式）' @('対象: VBAプロジェクト (xl/vbaProject.bin)')
                }
                return
            }
            $vi = Get-VbaInfo $b
            if ($vi.Project) { $pname = $vi.Project } else { $pname = '(名前を取得できませんでした)' }
            if ((Find-Bytes $b ([byte[]](0x43, 0x4D, 0x47, 0x3D))) -ge 0) { $cmg = 'あり' } else { $cmg = 'なし' }
            if ((Find-Bytes $b ([byte[]](0x47, 0x43, 0x3D))) -ge 0) { $gc = 'あり' } else { $gc = 'なし' }
            $d = @()
            $d += ("対象: VBAプロジェクト「{0}」 (xl/vbaProject.bin)" -f $pname)
            $d += ("操作: ロック情報 DPB= を DPx= に変更（バイト位置 {0} の1バイトを B から x に書換え）" -f $pos)
            $d += ("関連項目: CMG= {0} / GC= {1}（今回は変更しません）" -f $cmg, $gc)
            $d += "ロックはプロジェクト全体にかかっており、次のモジュールがまとめて保護されています:"
            $nAll = $vi.Doc.Count + $vi.Std.Count + $vi.Cls.Count + $vi.Frm.Count
            if ($nAll -eq 0) { $d += "  （モジュール一覧は取得できませんでした。処理には影響ありません）" }
            else {
                if ($vi.Doc.Count -gt 0) { $d += ("  ThisWorkbook/シート {0}個: {1}" -f $vi.Doc.Count, ($vi.Doc -join ', ')) }
                if ($vi.Std.Count -gt 0) { $d += ("  標準モジュール {0}個: {1}" -f $vi.Std.Count, ($vi.Std -join ', ')) }
                if ($vi.Cls.Count -gt 0) { $d += ("  クラスモジュール {0}個: {1}" -f $vi.Cls.Count, ($vi.Cls -join ', ')) }
                if ($vi.Frm.Count -gt 0) { $d += ("  フォーム {0}個: {1}" -f $vi.Frm.Count, ($vi.Frm -join ', ')) }
            }
            $d += "各モジュールのコード自体は変更しません"
            if ($apply) {
                Set-Ctx 'VBAプロジェクト (xl/vbaProject.bin)' 'DPB= を DPx= に書き換えて書き戻す'
                $state.Writing = $true
                $b[$pos + 2] = 0x78
                $e.Delete()
                $n = $zip.CreateEntry('xl/vbaProject.bin')
                $o = $n.Open()
                $o.Write($b, 0, $b.Length)
                $o.Close()
                $state.Writing = $false
                $state.Vba = 'DONE'
                Show-Result $S3 'OK' '1件 ロックを解除しました' $d
            } else {
                Show-Result $S3 'OK' '1件 解除できます（解除予定）' $d
            }
        } catch {
            Fail $S3 '処理中にエラー' $_.Exception.Message
        }
    }

    # ================= 次の手順の表示 =================
    function Show-NextSteps {
        Write-Host ""
        Write-Host "【次にやること】" -ForegroundColor Cyan
        Write-Host "  手順1: Shiftを押しながらファイルを開く  [必須]" -ForegroundColor Cyan
        Write-Host "         （起動時マクロが保護をかけ直すのを防ぐため）" -ForegroundColor Cyan
        Write-Host "  手順2: VBAプロジェクトのロック設定（新しいパスワードを付け直す）" -ForegroundColor Cyan
        Write-Host "         場所: VBE(Alt+F11) > VBAProject右クリック > VBAProjectのプロパティ > 保護タブ"
        switch ($state.Vba) {
            'DONE'    {
                Write-Host "         [実施してください] ③でロックを解除しました。" -ForegroundColor Cyan
                Write-Host "           ・Excelが読み込み警告を出しても、そのまま「はい/OK」で進める" -ForegroundColor Cyan
                Write-Host "           ・保護タブで「プロジェクトを表示用にロックする」を外す、または新パスワードを設定" -ForegroundColor Cyan
            }
            'ALREADY' { Write-Host "         [要確認] 既に DPx= に変更済みでした。Excelでの設定がまだなら上と同じ操作をしてください。" -ForegroundColor Yellow }
            'NOLOCK'  { Write-Host "         [今回は不要] ロックの記述が見つかりませんでした（ロックなし）。" -ForegroundColor Gray }
            'NOVBA'   { Write-Host "         [今回は不要] このファイルにはマクロがありません。" -ForegroundColor Gray }
            default   { Write-Host "         [ロックが残っています] ③を実行できませんでした（上の[注意]を確認）。" -ForegroundColor Yellow }
        }
        Write-Host "  手順3: 保存して閉じ、開き直してコンパイルを確認  [必須]" -ForegroundColor Cyan
        Write-Host "         （VBE > デバッグ > VBAProjectのコンパイル。PtrSafe不足などのエラー箇所が出ます）" -ForegroundColor Cyan
        Write-Host "  参考  : ブック構成の保護" -ForegroundColor Cyan
        if ($state.Wb -eq 'DONE') { Write-Host "         [解除済み] 非表示シートの再表示、シートの移動・コピーができる状態になりました。" -ForegroundColor Cyan }
        elseif ($state.Wb -eq 'NONE') { Write-Host "         [今回は不要] 構成の保護は元々かかっていませんでした。" -ForegroundColor Gray }
        else { Write-Host "         [構成の保護の状態が不明] ①を実行できませんでした（上の[注意]を確認）。" -ForegroundColor Yellow }
        Write-Host ""
        Write-Host "元に戻したい場合は次を実行（実行前のファイルに戻ります）:" -ForegroundColor Yellow
        Write-Host ("  Copy-Item -LiteralPath '{0}' -Destination '{1}' -Force" -f $bak, $src) -ForegroundColor Yellow
    }

    # ---- 実行ログ（画面の表示をそのまま、対象ファイルと同じフォルダに保存）----
    $tx = $false
    $logPath = ''
    try {
        $logDir = Split-Path -Parent $src
        if (-not $logDir) { $logDir = (Get-Location).Path }
        $logPath = Join-Path $logDir ("protection_log_" + (Get-Date).ToString('yyyyMMdd_HHmmss') + ".txt")
        Start-Transcript -Path $logPath | Out-Null
        $tx = $true
    } catch { }

    # ======================== 本処理 ========================
    try {
        Write-Host $line
        Write-Host "Excel保護解除スクリプト"
        if ($checkOnly) { Write-Host "モード: 事前チェックのみ（ファイルは一切変更しません）" } else { Write-Host "モード: 事前チェック → 問題なければ実行" }
        Write-Host $line

        # ############################################################
        #  フェーズ1: 事前チェック（読み取りのみ・全項目を最後まで確認）
        # ############################################################
        $state.Phase = 'CHECK'
        $state.Cur = $resCheck
        Write-Host "【事前チェック】（読み取りのみ。問題は途中で止まらず、全部洗い出します）"

        # --- チェック1: 実行環境 ---
        $langMode = "" + $ExecutionContext.SessionState.LanguageMode
        Set-Ctx 'PowerShellの言語モード' '.NETのメソッドを呼べる状態(FullLanguage)か確認する'
        if ($langMode -ne 'FullLanguage') {
            Fail $K1 'このPowerShellでは実行できません' ("言語モードが {0} です（会社のセキュリティ設定で制限されている可能性）" -f $langMode) @('このスクリプトは.NETの機能を使うため、FullLanguage でないと動きません。情報システム担当に確認してください。')
            # 以降の項目は確認できないため、下の else 側でまとめて「確認不可」にする
        }
        else {
            try {
                Add-Type -AssemblyName System.IO.Compression, System.IO.Compression.FileSystem
                Show-Result $K1 'OK' ("{0} / PowerShell {1}" -f $langMode, $PSVersionTable.PSVersion.ToString()) @()
            } catch {
                Set-Ctx 'ZIP処理ライブラリ' 'System.IO.Compression を読み込む'
                Fail $K1 'ZIPライブラリを読み込めません' $_.Exception.Message
            }
        }

        if ($state.Problems -eq 0) {
            # パスの解決（ファイル名だけでも可）
            $srcFull = $src
            if (-not [IO.Path]::IsPathRooted($srcFull)) { $srcFull = Join-Path $PWD.Path $srcFull }
            try { $srcFull = [IO.Path]::GetFullPath($srcFull) } catch { }
            $src  = $srcFull
            $stamp = (Get-Date).ToString('yyyyMMdd_HHmmss')
            $bak  = $src + "." + $stamp + ".bak"
            $work = $src + ".work"

            # --- チェック2: 対象ファイル ---
            $fileOk = $false
            Set-Ctx $src '対象ファイルの存在・形式・保存場所を確認する'
            if (-not (Test-Path -LiteralPath $src)) {
                Fail $K2 'ファイルが見つかりません' 'パスが存在しません。冒頭の $src を確認してください'
            } else {
                $ext = [IO.Path]::GetExtension($src).ToLower()
                if ($ext -eq '.xls') {
                    Fail $K2 '旧形式(.xls)には使えません' '.xls はバイナリ形式のため、この方法は使えません。.xlsm/.xlsx に変換してください'
                } else {
                    $fileOk = $true
                    $warn = @()
                    if ($src -match 'OneDrive') { $warn += 'パスに OneDrive を含みます。同期中だと書き込みに失敗することがあります' }
                    try {
                        $attr = [int](Get-Item -LiteralPath $src).Attributes
                        if (($attr -band 0x440000) -ne 0) { $warn += 'クラウド上のみ（オンライン専用）のファイルの可能性があります。先にローカルへダウンロードしてください' }
                    } catch { }
                    $sz = [math]::Round((Get-Item -LiteralPath $src).Length / 1KB)
                    if ($warn.Count -gt 0) { Show-Result $K2 'WARN' ("見つかりました（{0}, {1} KB）" -f $ext, $sz) $warn }
                    else { Show-Result $K2 'OK' ("見つかりました（{0}, {1} KB）" -f $ext, $sz) @($src) }
                }
            }

            if (-not $fileOk) {
                Mark-NotRun @($K3, $K4, $K5, $S1, $S2, $S3) '確認できません（対象ファイルの問題が先に必要）'
            } else {
                # --- チェック3: 書き込み可否 ---
                Set-Ctx $src '書き込みモードで排他的に開けるか確認する'
                try {
                    $fs = [IO.File]::Open($src, 'Open', 'ReadWrite', 'None')
                    $fs.Close()
                    Show-Result $K3 'OK' '書き込み可能です（Excelや同期ソフトは掴んでいません）' @()
                } catch {
                    Fail $K3 'ファイルを書き換えられません' $_.Exception.Message @('考えられる原因: Excelでそのファイルを開いたまま / OneDrive等が同期中 / 読み取り専用')
                }

                # --- チェック4: 空き容量（作業用コピー + バックアップ + 余裕）---
                Set-Ctx $src '同じドライブの空き容量を確認する'
                try {
                    $di = New-Object IO.DriveInfo([IO.Path]::GetPathRoot($src))
                    $need = (Get-Item -LiteralPath $src).Length * 3
                    $freeMB = [math]::Round($di.AvailableFreeSpace / 1MB)
                    $needMB = [math]::Round($need / 1MB, 1)
                    if ($di.AvailableFreeSpace -lt $need) {
                        Fail $K4 '空き容量が足りません' ("空き {0} MB < 必要の目安 {1} MB（ファイルの3倍）" -f $freeMB, $needMB)
                    } else {
                        Show-Result $K4 'OK' ("空き {0} MB（必要の目安 {1} MB）" -f $freeMB, $needMB) @()
                    }
                } catch {
                    Show-Result $K4 'WARN' '空き容量を確認できませんでした（ネットワークパス等）' @($_.Exception.Message)
                }

                # --- チェック5: ZIPとして開けるか（作業用コピーを読み取り専用で開く）---
                $zipOk = $false
                Set-Ctx $work '作業用コピーを作成し、読み取り専用でZIPとして開く'
                try {
                    Copy-Item -LiteralPath $src -Destination $work -Force -ErrorAction Stop
                    $zip = [IO.Compression.ZipFile]::OpenRead($work)
                    $zipOk = $true
                    Show-Result $K5 'OK' ("ZIPとして開けました（内部ファイル {0} 個）" -f $zip.Entries.Count) @()
                } catch {
                    Fail $K5 'ZIPとして開けません' $_.Exception.Message @('考えられる原因: ファイルを開くパスワード（暗号化）がかかっている / xlsx・xlsm形式ではない / 破損')
                }

                if (-not $zipOk) {
                    Mark-NotRun @($S1, $S2, $S3) '確認できません（チェック5が失敗し、中身を見られないため）'
                } else {
                    # シート名の対応表（取得できなくても続行。表示がファイル名になるだけ）
                    try {
                        $wbx = Get-TextEntry $zip.GetEntry('xl/workbook.xml')
                        $rel = Get-TextEntry $zip.GetEntry('xl/_rels/workbook.xml.rels')
                        $byRid = @{}
                        foreach ($m in [regex]::Matches($wbx, '<sheet\s[^>]*/>')) {
                            $tag = $m.Value
                            $nm  = [regex]::Match($tag, '\sname="([^"]*)"')
                            $rid = [regex]::Match($tag, 'r:id="([^"]*)"')
                            $st  = [regex]::Match($tag, 'state="([^"]*)"')
                            if ($nm.Success -and $rid.Success) {
                                $stv = ''
                                if ($st.Success) { $stv = $st.Groups[1].Value }
                                $byRid[$rid.Groups[1].Value] = @{ Name = [Net.WebUtility]::HtmlDecode($nm.Groups[1].Value); State = $stv }
                            }
                        }
                        foreach ($m in [regex]::Matches($rel, '<Relationship\s[^>]*>')) {
                            $id = [regex]::Match($m.Value, 'Id="([^"]*)"').Groups[1].Value
                            $tg = [regex]::Match($m.Value, 'Target="([^"]*)"').Groups[1].Value
                            if ($byRid.ContainsKey($id)) { $sheetInfo[($tg -replace '^/?(xl/)?', 'xl/')] = $byRid[$id] }
                        }
                    } catch { }

                    # ①②③ は互いに独立。失敗しても止めずに全部確認する
                    Step-Workbook $false
                    Step-Sheets $false
                    Step-Vba $false

                    try { $zip.Dispose() } catch { }
                    $zip = $null
                }
            }
        }
        else {
            Mark-NotRun @($K2, $K3, $K4, $K5, $S1, $S2, $S3) '確認できません（チェック1が失敗したため）'
        }

        # ---- 事前チェックの結論 ----
        Print-Summary $resCheck $planCheck '【事前チェックの結果】'
        if ($state.Fatal -gt 0 -or ($state.Problems -gt 0 -and -not $skipFailedItems)) {
            Write-Host ("問題が {0} 件あります。実行はしていません。元ファイルは変更していません。" -f $state.Problems) -ForegroundColor Red
            Write-Host "上の [問題あり] の「対象」「しようとした操作」「失敗の理由」を確認し、まとめて直してから再実行してください。" -ForegroundColor Red
            return
        }
        if ($state.Problems -gt 0) {
            Write-Host ("問題のある項目が {0} 件あります（上の [問題あり]）。" -f $state.Problems) -ForegroundColor Yellow
            Write-Host "実行すると、問題のある項目はスキップして、実行できる項目だけを実行します（スキップした保護は残ります）。" -ForegroundColor Yellow
        } else {
            Write-Host "問題はありませんでした。" -ForegroundColor Green
        }
        if ($checkOnly) {
            Write-Host "事前チェックのみのモードなので、ここで終了します（ファイルは変更していません）。" -ForegroundColor Green
            Write-Host "実行するには、冒頭の `$checkOnly を `$false にして、もう一度貼り付けてください。" -ForegroundColor Cyan
            return
        }

        # ############################################################
        #  フェーズ2: 実行（作業用コピーを加工 → 全部成功したら元ファイルへ反映）
        # ############################################################
        $state.Phase = 'APPLY'
        $state.Cur = $resApply
        $state.Stop = $false
        Write-Host ""
        Write-Host $line
        Write-Host "【実行】"

        # 実行1: バックアップ
        Set-Ctx $bak '元ファイルのコピー(.bak)を作成する'
        try {
            Copy-Item -LiteralPath $src -Destination $bak -Force -ErrorAction Stop
            $sz = [math]::Round((Get-Item -LiteralPath $bak).Length / 1KB)
            Show-Result $A1 'OK' ("作成しました（{0} KB）" -f $sz) @($bak)
        } catch {
            Fail $A1 'バックアップを作れません' $_.Exception.Message
            return
        }

        # 実行2: 作業用コピーを新しく作り直し、書き込みモードで開く
        Set-Ctx $work '作業用コピーを作成し、書き込みモードでZIPとして開く'
        try {
            Copy-Item -LiteralPath $src -Destination $work -Force -ErrorAction Stop
            $zip = [IO.Compression.ZipFile]::Open($work, 'Update')
            Show-Result $A2 'OK' '書き込みモードで開きました' @($work)
        } catch {
            Fail $A2 '作業用コピーを開けません' $_.Exception.Message
            return
        }

        # ①〜③ を順に実行（事前チェックを通っているので、通常は失敗しない。失敗したらそこで止まる）
        $stepList = @(
            @{ Name = $S1; Fn = { Step-Workbook $true } },
            @{ Name = $S2; Fn = { Step-Sheets $true } },
            @{ Name = $S3; Fn = { Step-Vba $true } }
        )
        foreach ($s in $stepList) {
            if ($state.Stop) { Show-Result $s.Name 'NOTRUN' '実行しませんでした（前の手順で失敗したため）' @() }
            else { & $s.Fn }
        }

        # 確定
        Write-Host ""
        Write-Host "【確定】"
        $okSteps = @($resApply | Where-Object { ($_.Step -eq $S1 -or $_.Step -eq $S2 -or $_.Step -eq $S3) -and $_.Status -eq 'OK' }).Count
        if ((-not $state.Stop) -and ($okSteps -eq 0)) {
            Show-Result $A3 'NOTRUN' '保存しません（解除できた項目がなく、変更がないため）' @()
            Show-Result $A4 'NOTRUN' '反映しません（元ファイルは変更していません）' @()
        } elseif ($state.Stop) {
            Show-Result $A3 'NOTRUN' '実行しませんでした（失敗があったため）' @()
            Show-Result $A4 'NOTRUN' '実行しませんでした（元ファイルは変更していません）' @()
        } else {
            Set-Ctx $work '作業用コピーへの変更を確定する（ZIPを閉じてファイルに書き込む）'
            try {
                $zip.Dispose()
                $zip = $null
                Show-Result $A3 'OK' '作業用コピーへ書き込みました' @($work)
            } catch {
                Fail $A3 '作業用コピーの保存に失敗' $_.Exception.Message
            }
            if (-not $state.Stop) {
                Set-Ctx $src '作業用コピーで元ファイルを上書きする'
                try {
                    Copy-Item -LiteralPath $work -Destination $src -Force -ErrorAction Stop
                    $state.Applied = $true
                    Show-Result $A4 'OK' '元ファイルへ反映しました' @($src)
                } catch {
                    $state.KeepWork = $true
                    Fail $A4 '元ファイルを上書きできません' $_.Exception.Message @("加工済みのファイルは次に残してあります: $work", '考えられる原因: 処理中にExcelや同期ソフトがファイルを掴んだ')
                }
            } else {
                Show-Result $A4 'NOTRUN' '実行しませんでした（元ファイルは変更していません）' @()
            }
        }
    }
    finally {
        if ($zip) { try { $zip.Dispose() } catch { } }
        if ($work -and -not $state.KeepWork -and (Test-Path -LiteralPath $work)) {
            Remove-Item -LiteralPath $work -Force -ErrorAction SilentlyContinue
        }
        if ($resApply.Count -gt 0) {
            Print-Summary $resApply $planApply '【実行結果まとめ】'
            if ($state.Stop) {
                Write-Host "失敗があったため中止しました。元ファイルは変更していません。" -ForegroundColor Red
                Write-Host "上の [失敗] の「対象」「しようとした操作」「失敗の理由」を確認してください。" -ForegroundColor Red
                if ($state.KeepWork) { Write-Host "加工済みファイル: $work" -ForegroundColor Yellow }
            } elseif ($state.Applied) {
                $nWarn = @($resApply | Where-Object { $_.Status -eq 'WARN' }).Count
                if ($nWarn -gt 0) {
                    Write-Host "一部の項目をスキップして、元ファイルへ反映しました。" -ForegroundColor Yellow
                    Write-Host "スキップした項目の保護は残っています。上の [注意] の行（対象・理由）を確認してください。" -ForegroundColor Yellow
                } else {
                    Write-Host "すべて正常に完了し、元ファイルへ反映しました。" -ForegroundColor Green
                }
                Show-NextSteps
            } else {
                Write-Host "解除できた項目がなかったため、元ファイルは変更していません。" -ForegroundColor Yellow
            }
        }
        if ($tx) {
            Write-Host ""
            Write-Host "実行ログ: $logPath"
            try { Stop-Transcript | Out-Null } catch { }
        }
    }
}

vbaブロック動作環境確認

powershell

Get-WinEvent -FilterHashtable @{LogName='Microsoft-Windows-Windows Defender/Operational'; Id=1121; StartTime=(Get-Date).AddHours(-24)} | Format-List TimeCreated, Message

vba

Option Explicit
'======================================================================
' VBA資産スキャナ（マクロは2つ: RunEnvProbe / RunVbaScan）
'   新PC（64bit・OneDrive/SharePoint環境）で動かないマクロの原因を、
'   「PtrSafe等の宣言の問題」「新環境のブロック」「パス・環境の問題」に切り分けて調べます。
'   管理者権限は不要です。
'
' 【使う順番】
'   1. RunEnvProbe : このPC・このExcelで、実際に何が動く／動かないかを診断する（先に実行）
'   2. RunVbaScan  : 対象ブックのコードを読み、問題になりそうな箇所を一覧にする
'   3. VBEで、対象ブックを デバッグ > VBAProjectのコンパイル し、残りの構文エラーを直す
'   ※ 修正したら、2と3をもう一度やって、直ったか確認する
'
' 【使う前の操作】（初回だけ）
'   A. 新しい空のブックを作り、.xlsm で保存する
'      （これが「調査用ブック」。調べる対象のブックとは別のブック）
'   B. Alt+F11 > 挿入 > 標準モジュール で空のモジュールを作り、このコード全体を貼り付ける
'      （新しいモジュールに Option Explicit が最初から書かれている場合は、先にそれを消してから貼る。
'        .basファイルなら、ファイル > ファイルのインポートでも可）
'   C. （RunVbaScan用）Excelの ファイル > オプション > トラストセンター > トラストセンターの設定 >
'      マクロの設定 で、「VBAプロジェクト オブジェクト モデルへのアクセスを信頼する」にチェックを入れる
'      ・グレーアウトして押せない場合は、会社のポリシーで固定されています。情報システム担当に依頼する
'      ・RunEnvProbe は、この設定がなくても動きます
'      ・調査が終わったら、チェックを外して元に戻すのが安全です
'   D. （RunVbaScan用）調べるブックのVBAプロジェクトのロックを、解除しておく
'      （ロックされたままだと、その旨を表示して止まります）
'
' 【使い方】
'   共通: Alt+F8 でマクロ名を選んで実行する（または、VBEでマクロの中にカーソルを置いて F5）
'
'   RunEnvProbe
'     ・調べるブックの指定は不要。結果は、新しいシート「環境診断_日時」に出る
'     ・「NG」「注意」の行を見る。API呼び出し・COM部品・ファイル操作・DBプロバイダー・
'       このブックの場所（URLになっていないか）・ファイルのブロックを、実機で試した結果
'     ・調査用ブックを保存してから実行すると、そのブックの場所についても診断できる
'
'   RunVbaScan
'     ・調べるブックを選ぶ画面が出る（下の TARGET_PATH が空欄の場合。固定したい場合はパスを書く）
'     ・対象ブックは、読み取り専用・マクロ無効で開く。一切変更せず、保存せずに閉じる
'     ・結果は、次の新しいシートに出る
'         結果_日時     : 要修正／要確認／情報 の一覧（先頭行のフィルターで絞り込める）
'         参照設定_日時 : 参照設定の一覧（旧PCでも実行し、見比べて差分を探す）
'         API読み込み_日時 : Declare文のDLL・関数を、このPCで読み込めるか（Windowsエラー番号つき）
'     ・まず「要修正」、次に「要確認」の順に見る。最後に、必ず上の手順3のコンパイルも行う
'
' 【注意】
'   ・結果は「新環境で問題になりそうな候補」の一覧です。実際に動かないかは、実行して確認が必要です
'   ・RunEnvProbe の結果は、実行したPC・ユーザー・Excelの環境での結果です
'
'======================================================================

'########################################################################
'★★★★★  書き換えるのはここだけ  ここから  ★★★★★
'########################################################################
'【任意】調べる対象のブック。空欄("")なら、実行時にファイル選択画面が出ます。固定したいときはフルパスを書く
Private Const TARGET_PATH As String = ""
'【任意】ユーザーフォーム上のコントロール種類も調べる（True / False）
Private Const SCAN_FORM_CONTROLS As Boolean = True
'【任意】Declare文のDLLを、このPCで実際に読み込めるか試す（True / False）
'        ※DLLを読み込むだけで、関数は呼びません。ただしDLLの初期化処理は実行されます
Private Const TEST_DECLARE_DLLS As Boolean = True
'【任意】RunEnvProbe: 外部プログラムの起動(Shell)も試す（True / False）
'        ※セキュリティ製品に検知ログが残る場合があります。通常は False のままでOK
Private Const PROBE_SHELL As Boolean = False
'【任意】RunEnvProbe: OneDrive同期フォルダ内に、一時ファイルを作って消す試験をする（True / False）
Private Const PROBE_SYNC_WRITE As Boolean = True
'【任意】RunEnvProbe: 到達できるか試したいパス（複数は ; 区切り）。例 "\\server\share;Z:\"
'        ※到達できない場所は応答待ちで、数十秒かかることがあります
Private Const PROBE_PATHS As String = ""
'########################################################################
'★★★★★  書き換えるのはここだけ  ここまで（これより下は触らない）  ★★★★★
'########################################################################

Private Const AUTOSEC_FORCE_DISABLE As Long = 3
Private Const STD_CTRL As String = "|Label|TextBox|ComboBox|ListBox|CheckBox|OptionButton|ToggleButton|CommandButton|TabStrip|MultiPage|ScrollBar|SpinButton|Image|Frame|RefEdit|Page|Tab|"
Private Const HANDLE_FUNCS As String = "|FindWindow|FindWindowEx|GetDC|GetActiveWindow|GetForegroundWindow|GetDesktopWindow|GetModuleHandle|LoadLibrary|OpenProcess|CreateFile|SendMessage|GetProcAddress|CreateCompatibleDC|SetTimer|GetParent|GetWindow|SetFocus|GetFocus|ShellExecute|SHBrowseForFolder|GetCurrentProcess|"
Private Const RISKY_PROGIDS As String = "mscal.|mscomctl|mscomct2|msscriptcontrol|scriptcontrol|mswinsock|msflexgrid|shell.explorer|comdlg32|commondialog|mscomm|msdatalist|msinet|mapi.session|internetexplorer.application"
Private Const SAFE_PROGIDS As String = "scripting.|wscript.|shell.application|msxml|xmlhttp|outlook.|word.|excel.|powerpoint.|adodb.|access.|vbscript."

Private mWs As Worksheet
Private mRow As Long
Private mStamp As String
Private mCntFix As Long
Private mCntChk As Long
Private mCntInfo As Long
Private mStage As String
Private mCondDepth As Long
Private mCondLegacy As Boolean
Private mCondInElse As Boolean
Private mDeclareCount As Long
Private mPw As Worksheet
Private mPRow As Long
Private mPNg As Long
Private mPWarn As Long
Private mDecl As Collection

Private reDecl As Object
Private rePath As Object
Private reHandleParam As Object
Private reRetLong As Object
Private reJet As Object
Private reAce As Object
Private reOdbc As Object
Private reDb As Object
Private reCreate As Object
Private rePrinter As Object
Private reOld As Object
Private reVarPtr As Object
Private reCurPath As Object
Private reFileFn As Object
Private reFileStmt As Object
Private reUrlSrc As Object
Private reDialog As Object
Private reShell As Object
Private reNet As Object
Private reSendKeys As Object
Private reEnviron As Object
Private reDeclParts As Object

' RunEnvProbe 用（このPCでWin32 API呼び出しが動くかを試すための宣言）
#If VBA7 Then
Private Declare PtrSafe Function GetTickCount Lib "kernel32" () As Long
#Else
Private Declare Function GetTickCount Lib "kernel32" () As Long
#End If

' DLLを読み込めるか試すための宣言（関数そのものは呼ばず、読み込みと関数の有無だけ調べる）
#If VBA7 Then
Private Declare PtrSafe Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As LongPtr
Private Declare PtrSafe Function GetProcAddress Lib "kernel32" (ByVal hModule As LongPtr, ByVal lpProcName As String) As LongPtr
Private Declare PtrSafe Function FreeLibrary Lib "kernel32" (ByVal hLibModule As LongPtr) As Long
#Else
Private Declare Function LoadLibraryA Lib "kernel32" (ByVal lpLibFileName As String) As Long
Private Declare Function GetProcAddress Lib "kernel32" (ByVal hModule As Long, ByVal lpProcName As String) As Long
Private Declare Function FreeLibrary Lib "kernel32" (ByVal hLibModule As Long) As Long
#End If

'======================================================================
' メイン
'======================================================================
Public Sub RunVbaScan()
    Dim targetPath As String
    Dim wb As Workbook
    Dim w As Workbook
    Dim oldSec As Long
    Dim oldEvt As Boolean
    Dim oldAlert As Boolean
    Dim oldScr As Boolean
    Dim opened As Boolean
    Dim done As Boolean
    Dim prot As Long
    Dim errNo As Long
    Dim errDesc As String
    Dim comp As Object

    targetPath = TARGET_PATH
    If Len(targetPath) = 0 Then targetPath = PickFile()
    If Len(targetPath) = 0 Then Exit Sub
    If Len(Dir(targetPath)) = 0 Then
        MsgBox "ファイルが見つかりません:" & vbLf & targetPath, vbExclamation, "VBA資産スキャナ"
        Exit Sub
    End If
    If StrComp(targetPath, ThisWorkbook.FullName, vbTextCompare) = 0 Then
        MsgBox "この調査用ブック自身は調べられません。別のブックを指定してください。", vbExclamation, "VBA資産スキャナ"
        Exit Sub
    End If

    oldSec = Application.AutomationSecurity
    oldEvt = Application.EnableEvents
    oldAlert = Application.DisplayAlerts
    oldScr = Application.ScreenUpdating

    On Error GoTo EH

    mStage = "調査用の設定を切り替える（マクロ無効・イベント無効）"
    Application.AutomationSecurity = AUTOSEC_FORCE_DISABLE
    Application.EnableEvents = False
    Application.DisplayAlerts = False
    Application.ScreenUpdating = False

    mStage = "対象ブックを読み取り専用で開く: " & targetPath
    For Each w In Workbooks
        If StrComp(w.FullName, targetPath, vbTextCompare) = 0 Then Set wb = w
    Next w
    If wb Is Nothing Then
        Set wb = Workbooks.Open(Filename:=targetPath, UpdateLinks:=0, ReadOnly:=True, AddToMru:=False)
        opened = True
    End If

    mStage = "VBAプロジェクトにアクセスできるか確認する"
    prot = -1
    On Error Resume Next
    prot = wb.VBProject.Protection
    errNo = Err.Number
    errDesc = Err.Description
    Err.Clear
    On Error GoTo EH
    If prot = -1 Then
        MsgBox "VBAプロジェクトにアクセスできません。" & vbLf & vbLf & _
               "「ファイル > オプション > トラストセンター > トラストセンターの設定 > マクロの設定」で" & vbLf & _
               "「VBAプロジェクト オブジェクト モデルへのアクセスを信頼する」にチェックを入れてください。" & vbLf & vbLf & _
               "エラー: " & errNo & " " & errDesc, vbExclamation, "VBA資産スキャナ"
        GoTo Cleanup
    End If
    If prot = 1 Then
        MsgBox "対象ブックのVBAプロジェクトがロックされています。" & vbLf & _
               "先にロックを解除してから、もう一度実行してください。", vbExclamation, "VBA資産スキャナ"
        GoTo Cleanup
    End If

    mStage = "結果シートを作る"
    mCntFix = 0: mCntChk = 0: mCntInfo = 0
    mDeclareCount = 0
    Set mDecl = New Collection
    CreateResultSheet targetPath
    InitRegex

    mStage = "ファイルのブロック（インターネット由来のマーク）を確認する"
    CheckMotw targetPath

    mStage = "参照設定を調べる"
    ScanReferences wb

    For Each comp In wb.VBProject.VBComponents
        mStage = "モジュール「" & comp.Name & "」のコードを調べる"
        ScanComponent comp
        If SCAN_FORM_CONTROLS Then
            mStage = "フォーム「" & comp.Name & "」のコントロールを調べる"
            ScanFormControls comp
        End If
    Next comp

    mStage = "シート上のActiveXコントロールを調べる"
    ScanSheetControls wb

    If mDeclareCount > 0 Then
        AddFinding "情報", "Win32 API(Declare)の使用", "(全体)", 0, mDeclareCount & " 個のDeclare文があります", "PtrSafeでも、新環境のセキュリティ設定（ASRルール「OfficeマクロからのWin32 API呼び出しをブロック」等）で実行を止められることがあります。RunEnvProbe で、このPCでAPI呼び出しが動くか確認できます"
    End If

    If TEST_DECLARE_DLLS Then
        mStage = "Declare文のDLL・関数を読み込めるか試す"
        TestDeclares
    End If

    mStage = "結果を整える"
    FinishResultSheet
    done = True

Cleanup:
    On Error Resume Next
    If opened Then wb.Close SaveChanges:=False
    Application.AutomationSecurity = oldSec
    Application.EnableEvents = oldEvt
    Application.DisplayAlerts = oldAlert
    Application.ScreenUpdating = oldScr
    If done Then mWs.Activate
    On Error GoTo 0
    If done Then
        MsgBox "スキャンが完了しました。" & vbLf & vbLf & _
               "要修正: " & mCntFix & " 件 / 要確認: " & mCntChk & " 件 / 情報: " & mCntInfo & " 件" & vbLf & _
               "結果シート: " & mWs.Name & vbLf & vbLf & _
               "※ 最後に VBE > デバッグ > VBAProjectのコンパイル も実行して、残りの構文エラーを確認してください。", _
               vbInformation, "VBA資産スキャナ"
    End If
    Exit Sub

EH:
    MsgBox "処理中にエラーが発生しました。" & vbLf & vbLf & _
           "しようとしていた操作: " & mStage & vbLf & _
           "エラー: " & Err.Number & " " & Err.Description, vbCritical, "VBA資産スキャナ"
    Resume Cleanup
End Sub

'======================================================================
' 結果シート
'======================================================================
Private Sub CreateResultSheet(ByVal targetPath As String)
    mStamp = Format$(Now, "mmdd") & "_" & Format$(Now, "hhnnss")
    Set mWs = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    mWs.Name = "結果_" & mStamp
    mWs.Range("A1").Value = "VBA資産スキャン結果（読み取り専用で調査。対象ブックは変更していません）"
    mWs.Range("A2").Value = "'対象: " & targetPath
    mWs.Range("A3").Value = "'調査日時: " & Format$(Now, "yyyy/mm/dd hh:nn:ss") & "  /  Excel " & Application.Version & IIf(IsExcel64(), " (64bit)", " (32bit)")
    mWs.Range("A5:F5").Value = Array("重要度", "種類", "モジュール/場所", "行", "内容", "対処のヒント")
    mWs.Range("A5:F5").Font.Bold = True
    mWs.Range("A5:F5").Interior.Color = RGB(221, 235, 247)
    mRow = 6
End Sub

Private Sub FinishResultSheet()
    mWs.Range("A4").Value = "要修正: " & mCntFix & " 件 / 要確認: " & mCntChk & " 件 / 情報: " & mCntInfo & " 件"
    mWs.Range("A1").Font.Bold = True
    mWs.Range("A4").Font.Bold = True
    mWs.Columns(1).ColumnWidth = 8
    mWs.Columns(2).ColumnWidth = 30
    mWs.Columns(3).ColumnWidth = 22
    mWs.Columns(4).ColumnWidth = 6
    mWs.Columns(5).ColumnWidth = 80
    mWs.Columns(6).ColumnWidth = 70
    On Error Resume Next
    If mRow > 6 Then
        mWs.Range("A5:F" & (mRow - 1)).AutoFilter
    Else
        mWs.Range("A5:F5").AutoFilter
    End If
    mWs.Activate
    ActiveWindow.FreezePanes = False
    mWs.Range("A6").Select
    ActiveWindow.FreezePanes = True
    On Error GoTo 0
End Sub

Private Sub AddFinding(ByVal level As String, ByVal kind As String, ByVal modName As String, ByVal lineNo As Long, ByVal txt As String, ByVal hint As String)
    Dim s As String
    s = txt
    If Len(s) > 300 Then s = Left$(s, 300) & "..."
    With mWs
        .Cells(mRow, 1).Value = level
        .Cells(mRow, 2).Value = kind
        .Cells(mRow, 3).Value = "'" & modName
        If lineNo > 0 Then .Cells(mRow, 4).Value = lineNo
        .Cells(mRow, 5).Value = "'" & s
        .Cells(mRow, 6).Value = hint
        Select Case level
            Case "要修正"
                .Range(.Cells(mRow, 1), .Cells(mRow, 6)).Interior.Color = RGB(255, 199, 206)
                mCntFix = mCntFix + 1
            Case "要確認"
                .Range(.Cells(mRow, 1), .Cells(mRow, 6)).Interior.Color = RGB(255, 235, 156)
                mCntChk = mCntChk + 1
            Case Else
                mCntInfo = mCntInfo + 1
        End Select
    End With
    mRow = mRow + 1
End Sub

'======================================================================
' 参照設定
'======================================================================
Private Sub ScanReferences(ByVal wb As Workbook)
    Dim ws As Worksheet
    Dim r As Long
    Dim ref As Object
    Dim nm As String, desc As String, pth As String, guid As String, ver As String
    Dim broken As Boolean, bi As Boolean

    Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    ws.Name = "参照設定_" & mStamp
    ws.Range("A1").Value = "参照設定の一覧（旧PCと新PCで同じマクロを実行して見比べる用）"
    ws.Range("A1").Font.Bold = True
    ws.Range("A3:G3").Value = Array("名前", "説明", "状態", "組み込み", "パス", "GUID", "バージョン")
    ws.Range("A3:G3").Font.Bold = True
    ws.Range("A3:G3").Interior.Color = RGB(221, 235, 247)
    r = 4

    For Each ref In wb.VBProject.References
        nm = "": desc = "": pth = "": guid = "": ver = "": broken = False: bi = False
        On Error Resume Next
        nm = ref.Name
        desc = ref.Description
        broken = ref.IsBroken
        bi = ref.BuiltIn
        pth = ref.FullPath
        guid = ref.GUID
        ver = CStr(ref.Major) & "." & CStr(ref.Minor)
        On Error GoTo 0
        ws.Cells(r, 1).Value = "'" & nm
        ws.Cells(r, 2).Value = "'" & desc
        If broken Then ws.Cells(r, 3).Value = "参照不可" Else ws.Cells(r, 3).Value = "OK"
        If bi Then ws.Cells(r, 4).Value = "はい" Else ws.Cells(r, 4).Value = "いいえ"
        ws.Cells(r, 5).Value = "'" & pth
        ws.Cells(r, 6).Value = "'" & guid
        ws.Cells(r, 7).Value = "'" & ver
        If broken Then
            ws.Range(ws.Cells(r, 1), ws.Cells(r, 7)).Interior.Color = RGB(255, 199, 206)
            AddFinding "要修正", "参照設定: 参照不可", "(参照設定)", 0, nm & "  [" & desc & "]  GUID=" & guid, "VBE > ツール > 参照設定 で「参照不可:」の項目。新PCに同等のライブラリがあれば選び直し、なければコード側を代替する"
        End If
        r = r + 1
    Next ref
    ws.Columns(1).ColumnWidth = 30
    ws.Columns(2).ColumnWidth = 50
    ws.Columns(3).ColumnWidth = 10
    ws.Columns(4).ColumnWidth = 10
    ws.Columns(5).ColumnWidth = 70
    ws.Columns(6).ColumnWidth = 40
    ws.Columns(7).ColumnWidth = 12
End Sub

'======================================================================
' モジュールのコード
'======================================================================
Private Sub ScanComponent(ByVal comp As Object)
    Dim cm As Object
    Dim n As Long
    Dim txt As String
    Dim lines() As String
    Dim i As Long
    Dim startLine As Long
    Dim cur As String
    Dim logical As String
    Dim compName As String

    On Error GoTo EH
    compName = comp.Name
    Set cm = comp.CodeModule
    n = cm.CountOfLines
    If n = 0 Then Exit Sub
    txt = cm.Lines(1, n)
    txt = Replace(Replace(txt, vbCrLf, vbLf), vbCr, vbLf)
    lines = Split(txt, vbLf)
    mCondDepth = 0
    mCondLegacy = False
    mCondInElse = False
    i = 0
    Do While i <= UBound(lines)
        startLine = i + 1
        cur = lines(i)
        logical = cur
        Do While IsContinued(cur) And i < UBound(lines)
            i = i + 1
            cur = lines(i)
            logical = Left$(RTrim$(logical), Len(RTrim$(logical)) - 1) & " " & Trim$(cur)
        Loop
        AnalyzeLine compName, startLine, logical
        i = i + 1
    Loop
    Exit Sub
EH:
    AddFinding "要確認", "読み取り失敗", compName, 0, "モジュールのコードを読み込めませんでした: " & Err.Number & " " & Err.Description, "このモジュールは手動で確認してください"
End Sub

Private Function IsContinued(ByVal s As String) As Boolean
    Dim t As String
    t = RTrim$(s)
    IsContinued = (Right$(t, 2) = " _") And (Left$(LTrim$(s), 1) <> "'")
End Function

Private Function StripComment(ByVal s As String) As String
    Dim i As Long
    Dim inQ As Boolean
    Dim ch As String
    For i = 1 To Len(s)
        ch = Mid$(s, i, 1)
        If ch = """" Then
            inQ = Not inQ
        ElseIf ch = "'" And Not inQ Then
            StripComment = Left$(s, i - 1)
            Exit Function
        End If
    Next i
    StripComment = s
End Function

Private Sub AnalyzeLine(ByVal modName As String, ByVal lineNo As Long, ByVal raw As String)
    Dim code As String
    Dim t As String
    Dim lt As String
    Dim legacy As Boolean
    Dim ms As Object
    Dim mt As Object

    code = StripComment(raw)
    t = Trim$(code)
    If Len(t) = 0 Then Exit Sub
    lt = LCase$(t)

    ' コンパイル条件（#If VBA7 など）の追跡
    If Left$(lt, 4) = "#if " Then
        mCondDepth = mCondDepth + 1
        If mCondDepth = 1 Then
            mCondLegacy = (InStr(lt, "vba7") > 0) Or (InStr(lt, "win64") > 0)
            mCondInElse = False
        End If
        Exit Sub
    End If
    If Left$(lt, 5) = "#else" Then
        If mCondDepth = 1 Then mCondInElse = True
        Exit Sub
    End If
    If Left$(lt, 7) = "#end if" Then
        mCondDepth = mCondDepth - 1
        If mCondDepth <= 0 Then
            mCondDepth = 0
            mCondLegacy = False
            mCondInElse = False
        End If
        Exit Sub
    End If
    legacy = (mCondDepth >= 1 And mCondLegacy And mCondInElse)

    If reDecl.Test(t) Then CheckDeclare modName, lineNo, t, legacy
    If legacy Then Exit Sub

    If rePath.Test(t) Then ClassifyPaths modName, lineNo, t
    If reCurPath.Test(t) Then
        AddFinding "要確認", "実行ブックの場所・カレントフォルダの取得", modName, lineNo, t, "OneDrive/SharePoint上で開いたブックは、Path が https:// のURLを返すことがある。Dir・Open・FileCopy・Kill・FileSystemObject はURLを扱えない。同期フォルダのローカルパスへ変換して使う（Environ(""OneDriveCommercial"") など）"
    End If
    If reFileFn.Test(t) Or reFileStmt.Test(t) Then
        AddFinding "情報", "ファイル操作", modName, lineNo, t, "対象がURL、または同期フォルダ（オンライン専用で未ダウンロード・同期中のロック）だと、失敗や動作の違いが出ることがある"
    End If
    If reUrlSrc.Test(t) Then
        AddFinding "情報", "SharePoint/OneDrive/URLの記述", modName, lineNo, t, "新環境向けの記述。パスの形式（URLか、ローカルの同期パスか）が処理と合っているか確認する"
    End If
    If reDialog.Test(t) Then
        AddFinding "情報", "ファイル選択ダイアログ", modName, lineNo, t, "OneDrive/SharePoint上のファイルを選ぶと、URLが返ることがある。返り値を Dir/Open 等へ渡していないか確認する"
    End If
    If reEnviron.Test(t) Then
        AddFinding "情報", "Environ(環境変数)", modName, lineNo, t, "環境変数の値は、新PC・新環境で変わる（ユーザー名、ホームフォルダ、OneDriveの場所など）"
    End If
    If reShell.Test(t) Then
        AddFinding "要確認", "外部プログラムの起動(Shell等)", modName, lineNo, t, "新環境のセキュリティ設定（ASRルール「Officeが子プロセスを作成することをブロック」等）で止められることがある。情報システム担当に確認する"
    End If
    If reNet.Test(t) Then
        AddFinding "要確認", "外部通信(HTTP等)", modName, lineNo, t, "プロキシ・セキュリティ設定・TLS設定で失敗することがある。InternetExplorer連携は廃止済み"
    End If
    If reSendKeys.Test(t) Then
        AddFinding "要確認", "SendKeys", modName, lineNo, t, "画面操作の自動入力は、新環境のダイアログ（OneDrive/SharePoint）やフォーカスで動作が変わる。可能ならオブジェクトモデルで置き換える"
    End If
    If reJet.Test(t) Then
        AddFinding "要修正", "DB接続: Jet", modName, lineNo, t, "Jet 4.0 は64bit版Officeでは使えません。ACE.OLEDB（Microsoft.ACE.OLEDB.12.0 など）へ変更し、新PCにACEドライバを入れる"
    End If
    If reAce.Test(t) Then
        AddFinding "要確認", "DB接続: ACE", modName, lineNo, t, "新PCにACEドライバが必要。Officeと同じビット数のものを入れる"
    End If
    If reOdbc.Test(t) Then
        AddFinding "要確認", "DB接続: ODBC", modName, lineNo, t, "DSNやドライバはPCごとの設定。新PCに同じものがあるか確認する"
    End If
    If reDb.Test(t) Then
        AddFinding "情報", "DB・Access利用", modName, lineNo, t, "接続先ファイル・参照設定が新PCにあるか確認する"
    End If
    If reCreate.Test(t) Then
        Set ms = reCreate.Execute(t)
        For Each mt In ms
            CheckProgId modName, lineNo, CStr(mt.SubMatches(1)), t
        Next mt
    End If
    If rePrinter.Test(t) Then
        AddFinding "要確認", "プリンタ名の指定", modName, lineNo, t, "プリンタ名・ポートは環境依存。新PCの名前と一致するか確認する"
    End If
    If reOld.Test(t) Then
        AddFinding "要修正", "廃止された機能", modName, lineNo, t, "Application.FileSearch は Excel 2007以降で廃止。Dir関数やFileSystemObjectに置き換える"
    End If
    If reVarPtr.Test(t) Then
        AddFinding "要確認", "VarPtr/StrPtr/ObjPtr", modName, lineNo, t, "戻り値はアドレス(LongPtr)。Long型の変数に入れていると64bitで誤動作する"
    End If
End Sub

Private Sub CheckDeclare(ByVal modName As String, ByVal lineNo As Long, ByVal t As String, ByVal legacy As Boolean)
    Dim hasPtr As Boolean
    Dim head As String
    Dim p As Long
    Dim fns() As String
    Dim k As Long

    hasPtr = (InStr(1, t, "PtrSafe", vbTextCompare) > 0)
    If legacy Then
        AddFinding "情報", "Declare(旧環境用の分岐)", modName, lineNo, t, "#If VBA7 / Win64 の #Else 側なので、新環境では使われません。問題なし"
        Exit Sub
    End If
    mDeclareCount = mDeclareCount + 1
    CollectDecl modName, lineNo, t
    If Not hasPtr Then
        AddFinding "要修正", "Declare に PtrSafe がない", modName, lineNo, t, "Declare の直後に PtrSafe を追加。ハンドルやポインタを表す Long は LongPtr に変更（#If VBA7 で旧環境と両対応も可）"
    End If
    If reHandleParam.Test(t) Then
        AddFinding "要確認", "Declare: 引数が Long のまま？", modName, lineNo, t, "ハンドル・ポインタ・LPARAM/WPARAM 系の引数は LongPtr が必要な場合があります（APIの仕様で確認）"
    End If
    If reRetLong.Test(t) Then
        p = InStr(t, "(")
        If p > 0 Then head = Left$(t, p - 1) Else head = t
        fns = Split(HANDLE_FUNCS, "|")
        For k = LBound(fns) To UBound(fns)
            If Len(fns(k)) > 0 Then
                If InStr(1, head, fns(k), vbTextCompare) > 0 Then
                    AddFinding "要確認", "Declare: 戻り値が Long のまま？", modName, lineNo, t, "ハンドルなどを返す関数は、戻り値を LongPtr にする必要があります"
                    Exit For
                End If
            End If
        Next k
    End If
End Sub

Private Sub CheckProgId(ByVal modName As String, ByVal lineNo As Long, ByVal pid As String, ByVal t As String)
    Dim lp As String
    Dim keys() As String
    Dim k As Long
    lp = LCase$(pid)
    keys = Split(RISKY_PROGIDS, "|")
    For k = LBound(keys) To UBound(keys)
        If Len(keys(k)) > 0 Then
            If InStr(lp, keys(k)) > 0 Then
                AddFinding "要確認", "CreateObject/GetObject: " & pid, modName, lineNo, t, "新PCで使えない可能性（32bit専用・未登録・廃止済みなど）。新PCにあるか確認する"
                Exit Sub
            End If
        End If
    Next k
    keys = Split(SAFE_PROGIDS, "|")
    For k = LBound(keys) To UBound(keys)
        If Len(keys(k)) > 0 Then
            If InStr(lp, keys(k)) > 0 Then Exit Sub
        End If
    Next k
    AddFinding "情報", "CreateObject/GetObject: " & pid, modName, lineNo, t, "このProgIDのコンポーネントが新PCに登録されているか確認する"
End Sub

'======================================================================
' フォーム上のコントロール／シート上のActiveX
'======================================================================
Private Sub ScanFormControls(ByVal comp As Object)
    Dim ctl As Object
    Dim tn As String
    Dim compName As String
    On Error GoTo EH
    compName = comp.Name
    If comp.Type <> 3 Then Exit Sub
    For Each ctl In comp.Designer.Controls
        tn = TypeName(ctl)
        If InStr(1, STD_CTRL, "|" & tn & "|", vbTextCompare) = 0 Then
            AddFinding "要確認", "フォーム上の標準外コントロール", compName, 0, ctl.Name & " : " & tn, "ActiveX(OCX)の可能性。新PCに登録されているか確認する"
        End If
    Next ctl
    Exit Sub
EH:
    AddFinding "要確認", "読み取り失敗", compName, 0, "フォームのコントロール一覧を取得できませんでした: " & Err.Number & " " & Err.Description, "このフォームは手動で確認してください"
End Sub

Private Sub ScanSheetControls(ByVal wb As Workbook)
    Dim ws As Object
    Dim ole As Object
    Dim pid As String
    Dim nm As String
    Dim cnt As Long
    For Each ws In wb.Worksheets
        cnt = 0
        On Error Resume Next
        cnt = ws.OLEObjects.Count
        If Err.Number <> 0 Then
            AddFinding "要確認", "読み取り失敗", CStr(ws.Name), 0, "シート上のコントロール一覧を取得できませんでした: " & Err.Number & " " & Err.Description, "このシートは手動で確認してください"
            Err.Clear
            cnt = 0
        End If
        On Error GoTo 0
        If cnt > 0 Then
            For Each ole In ws.OLEObjects
                pid = "": nm = ""
                On Error Resume Next
                pid = ole.progID
                nm = ole.Name
                On Error GoTo 0
                If Len(pid) > 0 And Left$(pid, 6) <> "Forms." Then
                    AddFinding "要確認", "シート上のActiveXコントロール", CStr(ws.Name), 0, nm & " : " & pid, "旧環境にしかないOCXの可能性。新PCに登録されているか確認する"
                End If
            Next ole
        End If
    Next ws
End Sub

'======================================================================
' 部品
'======================================================================
Private Function IsExcel64() As Boolean
#If Win64 Then
    IsExcel64 = True
#Else
    IsExcel64 = False
#End If
End Function

Private Function PickFile() As String
    Dim fd As Object
    Set fd = Application.FileDialog(3)
    With fd
        .Title = "調べるExcelブックを選んでください"
        .AllowMultiSelect = False
        .Filters.Clear
        .Filters.Add "Excelブック", "*.xlsm;*.xlsx;*.xlsb;*.xls"
        If .Show = -1 Then PickFile = .SelectedItems(1)
    End With
End Function

Private Function MakeRx(ByVal pat As String, Optional ByVal glob As Boolean = False) As Object
    Dim r As Object
    Set r = CreateObject("VBScript.RegExp")
    r.Pattern = pat
    r.IgnoreCase = True
    r.Global = glob
    Set MakeRx = r
End Function

Private Sub InitRegex()
    Dim Q As String
    Q = Chr$(34)
    Set reDecl = MakeRx("^(Public\s+|Private\s+)?Declare\s+(PtrSafe\s+)?(Function|Sub)\s+")
    Set rePath = MakeRx(Q & "([A-Za-z]:\\|\\\\)[^" & Q & "]*" & Q, True)
    Set reHandleParam = MakeRx("\b(hwnd\w*|hdc|hmenu|hinst\w*|hmodule|hprocess|hfile|hhandle|hobject|hbitmap|hicon|hcursor|hfont|hbrush|hpen|hrgn|hkey|hthread|wparam|lparam|lpaddress|dwextrainfo)\s+As\s+Long\b")
    Set reRetLong = MakeRx("\)\s*As\s+Long\s*$")
    Set reJet = MakeRx("Jet\.OLEDB|Microsoft\.Jet")
    Set reAce = MakeRx("ACE\.OLEDB")
    Set reOdbc = MakeRx("\bDSN\s*=|\bDriver\s*=\s*\{")
    Set reDb = MakeRx("\bADODB\.|\bDAO\.|\.mdb\b|\.accdb\b")
    Set reCreate = MakeRx("(CreateObject|GetObject)\s*\(\s*" & Q & "([^" & Q & "]+)" & Q, True)
    Set rePrinter = MakeRx("\bActivePrinter\b")
    Set reOld = MakeRx("Application\.FileSearch")
    Set reVarPtr = MakeRx("\b(VarPtr|StrPtr|ObjPtr)\b")
    Set reCurPath = MakeRx("\b(ThisWorkbook|ActiveWorkbook)\s*\.\s*(Path|FullName)\b|\bWorkbooks\s*\([^)]*\)\s*\.\s*(Path|FullName)\b|\bCurDir\b|\bChDir\b|\bChDrive\b|\bDefaultFilePath\b")
    Set reFileFn = MakeRx("\b(Dir|FileCopy|Kill|MkDir|RmDir|FileLen|FileDateTime|GetAttr|SetAttr)\s*\(|\.(CopyFile|MoveFile|DeleteFile|CopyFolder|MoveFolder|DeleteFolder|CreateFolder|FileExists|FolderExists|GetFolder|GetFile|OpenTextFile|CreateTextFile|SaveAs|SaveCopyAs)\b")
    Set reFileStmt = MakeRx("^(Open\s+.+\s+For\s+(Input|Output|Append|Binary|Random)\b|(Kill|MkDir|RmDir|FileCopy|ChDir)\s+|Name\s+[^=]+\s+As\s+)")
    Set reUrlSrc = MakeRx("https?://|sharepoint\.com|DavWWWRoot|@SSL|d\.docs\.live\.net|OneDrive")
    Set reDialog = MakeRx("\b(GetOpenFilename|GetSaveAsFilename|FileDialog)\b")
    Set reShell = MakeRx("\bShell\s*\(|^Shell\s+|WScript\.Shell|Shell\.Application|\bShellExecute|\bcmd(\.exe)?\s+/[ck]\b|\bpowershell\b|\bcscript\b|\bwscript\b|\bmshta\b|\brundll32\b|\bregsvr32\b")
    Set reNet = MakeRx("XMLHTTP|WinHttp|URLDownloadToFile|InternetExplorer|Net\.WebClient|\bWebClient\b")
    Set reSendKeys = MakeRx("\bSendKeys\b")
    Set reEnviron = MakeRx("\bEnviron\s*\$?\s*\(")
    Set reDeclParts = MakeRx("Declare\s+(?:PtrSafe\s+)?(?:Function|Sub)\s+(\w+)\s+Lib\s+" & Q & "([^" & Q & "]+)" & Q & "(?:\s+Alias\s+" & Q & "([^" & Q & "]+)" & Q & ")?")
End Sub

'======================================================================
' パスの分類（固定パス）
'======================================================================
Private Sub ClassifyPaths(ByVal modName As String, ByVal lineNo As Long, ByVal t As String)
    Dim ms As Object
    Dim mt As Object
    Dim s As String
    Dim kind As String
    Dim hint As String
    Set ms = rePath.Execute(t)
    For Each mt In ms
        s = Mid$(CStr(mt.Value), 2)
        If Left$(s, 2) = "\\" Then
            kind = "固定パス: ネットワーク(UNC)"
            hint = "旧ファイルサーバーを指している可能性。新環境（OneDrive/SharePoint）に同じ場所があるか確認する。SharePointのWebDAV形式（\\xxx@SSL\DavWWWRoot\...）は環境依存"
        ElseIf UCase$(Left$(s, 1)) = "C" Then
            kind = "固定パス: ローカル(C:)"
            hint = "C:\Users\旧ユーザー名 など、PC・ユーザー固有の決め打ちに注意。新PCに同じフォルダがあるか確認する"
        Else
            kind = "固定パス: ドライブ文字(" & UCase$(Left$(s, 1)) & ":)"
            hint = "ネットワークドライブの割り当て（旧環境の共有フォルダ）の可能性。新PCにそのドライブ文字があるか、OneDrive/SharePointへ置き換える必要がないか確認する"
        End If
        AddFinding "要確認", kind, modName, lineNo, CStr(mt.Value) & "   [" & t & "]", hint
    Next mt
End Sub

'======================================================================
' ファイルのブロック（インターネット由来のマーク / MOTW）
'======================================================================
Private Function GetZoneId(ByVal filePath As String) As String
    Dim ff As Integer
    Dim ln As String
    On Error GoTo EH
    ff = FreeFile
    Open filePath & ":Zone.Identifier" For Input As #ff
    Do While Not EOF(ff)
        Line Input #ff, ln
        If LCase$(Left$(ln, 7)) = "zoneid=" Then
            GetZoneId = Trim$(Mid$(ln, 8))
            Exit Do
        End If
    Loop
    Close #ff
    Exit Function
EH:
    On Error Resume Next
    Close #ff
End Function

Private Sub CheckMotw(ByVal filePath As String)
    Dim z As String
    z = GetZoneId(filePath)
    If z = "3" Or z = "4" Then
        AddFinding "要修正", "ファイルのブロック(MOTW)", "(ファイル)", 0, "ZoneId=" & z, "インターネット/ダウンロード由来のファイルは、マクロが無効化されます。ファイルを右クリック > プロパティ > 「許可する」にチェック、または信頼できる場所へ移動する"
    ElseIf Len(z) > 0 Then
        AddFinding "情報", "ファイルのブロック(MOTW)", "(ファイル)", 0, "ZoneId=" & z, "通常は問題ありません"
    Else
        AddFinding "情報", "ファイルのブロック(MOTW)", "(ファイル)", 0, "ブロックのマークは見つかりませんでした（または確認できませんでした）", "マクロが動かない場合は、信頼できる場所・信頼できる発行元の設定も確認する"
    End If
End Sub

'======================================================================
' 環境診断（RunEnvProbe）: このPC・このExcelで、実際に試して結果を出す
'======================================================================
Public Sub RunEnvProbe()
    Dim wp As String
    Dim names As Variant
    Dim n As Variant
    Dim folder As String
    Dim paths() As String
    Dim i As Long
    Dim p As String
    Dim ids As Variant
    Dim provs As Variant
    Dim oldScr As Boolean

    oldScr = Application.ScreenUpdating
    On Error GoTo EH
    Application.ScreenUpdating = False

    mStage = "診断結果シートを作る"
    CreateProbeSheet

    mStage = "環境情報を調べる"
    ProbeAdd "Excel", "情報", "バージョン " & Application.Version & IIf(IsExcel64(), " (64bit)", " (32bit)") & " / " & SafeBuild(), "Declare文などは、このビット数で解釈されます"
    ProbeAdd "OS", "情報", SafeOs(), ""
    ProbeAdd "ユーザー名 / PC名", "情報", Environ$("USERNAME") & " / " & Environ$("COMPUTERNAME"), "コード中の固定のユーザー名・PC名と違っていないか"

    mStage = "このブックの場所を調べる"
    wp = ThisWorkbook.Path
    If LCase$(Left$(wp, 4)) = "http" Then
        ProbeAdd "このブックの場所 (ThisWorkbook.Path)", "注意", wp, "URL形式です。VBAのファイル操作（Dir・Open・FileCopy・FileSystemObject等）はURLを扱えません。同期フォルダのローカルパスへ変換する必要があります"
    ElseIf Len(wp) = 0 Then
        ProbeAdd "このブックの場所 (ThisWorkbook.Path)", "情報", "(未保存)", "このブックを保存してから実行すると、場所の診断もできます"
    Else
        ProbeAdd "このブックの場所 (ThisWorkbook.Path)", "情報", wp, "ローカルパスです"
        ProbeFileIO "このブックのフォルダでのファイル作成・削除", wp
        ProbeMotw ThisWorkbook.FullName
    End If
    ProbeAdd "カレントフォルダ (CurDir)", "情報", CurDir$, ""
    ProbeAdd "既定の保存先 (DefaultFilePath)", "情報", Application.DefaultFilePath, ""

    mStage = "OneDriveの同期フォルダを調べる"
    names = Array("OneDrive", "OneDriveCommercial", "OneDriveConsumer")
    For Each n In names
        folder = Environ$(CStr(n))
        If Len(folder) = 0 Then
            ProbeAdd "環境変数 " & CStr(n), "情報", "(未設定)", ""
        ElseIf FolderExistsSafe(folder) Then
            ProbeAdd "環境変数 " & CStr(n), "情報", folder, "同期フォルダの場所（ローカル）"
            If PROBE_SYNC_WRITE Then ProbeFileIO "同期フォルダでのファイル作成・削除（" & CStr(n) & "）", folder
        Else
            ProbeAdd "環境変数 " & CStr(n), "注意", folder & "  (フォルダが見つかりません)", ""
        End If
    Next n

    mStage = "ファイル操作（一時フォルダ）を試す"
    ProbeFileIO "一時フォルダでのファイル作成・削除", Environ$("TEMP")

    mStage = "Win32 API呼び出しを試す"
    ProbeApi

    mStage = "COM部品の生成を試す"
    ids = Array("Scripting.FileSystemObject", "Scripting.Dictionary", "WScript.Shell", "Shell.Application", "ADODB.Connection", "ADODB.Recordset", "MSXML2.XMLHTTP.6.0", "MSXML2.DOMDocument.6.0", "VBScript.RegExp", "MSScriptControl.ScriptControl")
    For i = LBound(ids) To UBound(ids)
        ProbeCom CStr(ids(i))
    Next i

    mStage = "DBプロバイダーの登録を調べる"
    provs = Array("Microsoft.Jet.OLEDB.4.0", "Microsoft.ACE.OLEDB.12.0", "Microsoft.ACE.OLEDB.16.0")
    For i = LBound(provs) To UBound(provs)
        ProbeProvider CStr(provs(i))
    Next i

    If PROBE_SHELL Then
        mStage = "外部プログラムの起動を試す"
        ProbeShell
    Else
        ProbeAdd "外部プログラムの起動 (Shell)", "情報", "試していません（PROBE_SHELL = False）", "試す場合は、冒頭の設定を True にする"
    End If

    If Len(PROBE_PATHS) > 0 Then
        mStage = "指定パスへの到達を試す"
        paths = Split(PROBE_PATHS, ";")
        For i = LBound(paths) To UBound(paths)
            p = Trim$(paths(i))
            If Len(p) > 0 Then ProbePath p
        Next i
    End If

    mStage = "結果を整える"
    FinishProbeSheet
    Application.ScreenUpdating = oldScr
    MsgBox "環境診断が完了しました。" & vbLf & "NG: " & mPNg & " 件 / 注意: " & mPWarn & " 件" & vbLf & "結果シート: " & mPw.Name, vbInformation, "環境診断"
    Exit Sub
EH:
    Application.ScreenUpdating = oldScr
    MsgBox "診断中にエラーが発生しました。" & vbLf & "しようとしていた操作: " & mStage & vbLf & "エラー: " & Err.Number & " " & Err.Description, vbCritical, "環境診断"
End Sub

Private Sub CreateProbeSheet()
    Set mPw = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    mPw.Name = "環境診断_" & Format$(Now, "mmdd") & "_" & Format$(Now, "hhnnss")
    mPw.Range("A1").Value = "環境診断（このPC・このExcelで、実際に試した結果）"
    mPw.Range("A1").Font.Bold = True
    mPw.Range("A2").Value = "読み方1: VBEの デバッグ > VBAProjectのコンパイル が通る → PtrSafe/LongPtrなど「宣言」の問題はありません。"
    mPw.Range("A3").Value = "読み方2: コンパイルは通るのに実行で止まる → 新環境のブロック、またはパス・環境の問題。止まったときのエラー番号の目安:"
    mPw.Range("A4").Value = "     53/76=ファイル・パスが見つからない  70=アクセス拒否  75=パス/ファイルのアクセスエラー  429=COM部品を作れない  48/453=DLL・API関数を読み込めない"
    mPw.Range("A6:D6").Value = Array("項目", "結果", "内容", "意味・対処")
    mPw.Range("A6:D6").Font.Bold = True
    mPw.Range("A6:D6").Interior.Color = RGB(221, 235, 247)
    mPRow = 7
    mPNg = 0
    mPWarn = 0
End Sub

Private Sub FinishProbeSheet()
    mPw.Columns(1).ColumnWidth = 46
    mPw.Columns(2).ColumnWidth = 8
    mPw.Columns(3).ColumnWidth = 70
    mPw.Columns(4).ColumnWidth = 80
    On Error Resume Next
    mPw.Activate
    ActiveWindow.FreezePanes = False
    mPw.Range("A7").Select
    ActiveWindow.FreezePanes = True
    On Error GoTo 0
End Sub

Private Sub ProbeAdd(ByVal itm As String, ByVal result As String, ByVal detail As String, ByVal meaning As String)
    With mPw
        .Cells(mPRow, 1).Value = "'" & itm
        .Cells(mPRow, 2).Value = result
        .Cells(mPRow, 3).Value = "'" & detail
        .Cells(mPRow, 4).Value = meaning
        Select Case result
            Case "NG"
                .Range(.Cells(mPRow, 1), .Cells(mPRow, 4)).Interior.Color = RGB(255, 199, 206)
                mPNg = mPNg + 1
            Case "注意"
                .Range(.Cells(mPRow, 1), .Cells(mPRow, 4)).Interior.Color = RGB(255, 235, 156)
                mPWarn = mPWarn + 1
        End Select
    End With
    mPRow = mPRow + 1
End Sub

Private Function SafeBuild() As String
    On Error Resume Next
    SafeBuild = "Build " & Application.Build
End Function

Private Function SafeOs() As String
    On Error Resume Next
    SafeOs = Application.OperatingSystem
End Function

Private Function FolderExistsSafe(ByVal folder As String) As Boolean
    Dim a As Long
    On Error Resume Next
    a = GetAttr(folder)
    If Err.Number = 0 Then FolderExistsSafe = ((a And vbDirectory) <> 0)
    Err.Clear
End Function

Private Sub ProbeFileIO(ByVal label As String, ByVal folder As String)
    Dim f As String
    Dim ff As Integer
    Dim en As Long
    Dim ed As String
    If Len(folder) = 0 Then
        ProbeAdd label, "情報", "フォルダが指定されていません", ""
        Exit Sub
    End If
    If Right$(folder, 1) <> "\" Then folder = folder & "\"
    f = folder & "_probe_delete_me_" & Format$(Now, "hhnnss") & ".tmp"
    On Error GoTo EH
    ff = FreeFile
    Open f For Output As #ff
    Print #ff, "probe"
    Close #ff
    Kill f
    ProbeAdd label, "OK", folder, "VBAのファイル操作（作成・書き込み・削除）が使えます"
    Exit Sub
EH:
    en = Err.Number
    ed = Err.Description
    On Error Resume Next
    Close #ff
    Kill f
    On Error GoTo 0
    ProbeAdd label, "NG", folder & "  エラー " & en & ": " & ed, "70=アクセス拒否 / 75=パスのアクセスエラー / 76=パスが見つからない。フォルダの権限・同期状態・パス形式を確認"
End Sub

Private Sub ProbeApi()
    Dim t As Long
    On Error GoTo EH
    t = GetTickCount()
    ProbeAdd "Win32 API の呼び出し（Declare）", "OK", "GetTickCount = " & t, "PtrSafe宣言とAPI呼び出しは、このPCでは動作しています"
    Exit Sub
EH:
    ProbeAdd "Win32 API の呼び出し（Declare）", "NG", "エラー " & Err.Number & ": " & Err.Description, "APIの呼び出しがブロックされている可能性（セキュリティ設定・ASRルール等）。情報システム担当に確認する"
End Sub

Private Sub ProbeCom(ByVal progId As String)
    Dim o As Object
    Dim en As Long
    Dim ed As String
    On Error Resume Next
    Set o = CreateObject(progId)
    en = Err.Number
    ed = Err.Description
    Err.Clear
    Set o = Nothing
    On Error GoTo 0
    If en = 0 Then
        ProbeAdd "COM部品の生成: " & progId, "OK", "生成できました", ""
    Else
        ProbeAdd "COM部品の生成: " & progId, "NG", "エラー " & en & ": " & ed, "未登録・32bit専用・ブロックの可能性。このProgIDを使うコードは動きません"
    End If
End Sub

Private Sub ProbeProvider(ByVal prov As String)
    Dim sh As Object
    Dim v As String
    Dim en As Long
    On Error Resume Next
    Set sh = CreateObject("WScript.Shell")
    If sh Is Nothing Then
        On Error GoTo 0
        ProbeAdd "DBプロバイダーの登録: " & prov, "情報", "確認できません（WScript.Shellを生成できない）", ""
        Exit Sub
    End If
    Err.Clear
    v = sh.RegRead("HKCR\" & prov & "\CLSID\")
    en = Err.Number
    Err.Clear
    On Error GoTo 0
    If en = 0 And Len(v) > 0 Then
        ProbeAdd "DBプロバイダーの登録: " & prov, "OK", "登録あり " & v, ""
    Else
        ProbeAdd "DBプロバイダーの登録: " & prov, "注意", "登録が見つかりません", "このプロバイダーを使うコードは動きません（Jetは64bit版には存在しません。ACEはドライバのインストールが必要）"
    End If
End Sub

Private Sub ProbeShell()
    Dim id As Double
    On Error GoTo EH
    id = Shell("cmd.exe /c exit 0", vbHide)
    ProbeAdd "外部プログラムの起動 (Shell)", "OK", "起動できました", ""
    Exit Sub
EH:
    ProbeAdd "外部プログラムの起動 (Shell)", "NG", "エラー " & Err.Number & ": " & Err.Description, "外部プログラムの起動がブロックされている可能性（ASRルール等）。Shell/WScript.Shellを使うコードは動きません"
End Sub

Private Sub ProbePath(ByVal p As String)
    Dim a As Long
    Dim t0 As Single
    Dim en As Long
    Dim ed As String
    t0 = Timer
    On Error Resume Next
    a = GetAttr(p)
    en = Err.Number
    ed = Err.Description
    Err.Clear
    On Error GoTo 0
    If en = 0 Then
        ProbeAdd "パスへの到達: " & p, "OK", "到達できました（" & Format$(Timer - t0, "0.0") & "秒）", ""
    Else
        ProbeAdd "パスへの到達: " & p, "NG", "到達できません（" & Format$(Timer - t0, "0.0") & "秒） エラー " & en & ": " & ed, "旧環境の共有フォルダ・ドライブの割り当てが、新環境にないことを示します"
    End If
End Sub

Private Sub ProbeMotw(ByVal filePath As String)
    Dim z As String
    z = GetZoneId(filePath)
    If z = "3" Or z = "4" Then
        ProbeAdd "このブックのブロック(MOTW)", "NG", "ZoneId=" & z, "インターネット/ダウンロード由来のファイルは、マクロが無効化されます。プロパティの「許可する」、または信頼できる場所へ"
    ElseIf Len(z) > 0 Then
        ProbeAdd "このブックのブロック(MOTW)", "情報", "ZoneId=" & z, ""
    Else
        ProbeAdd "このブックのブロック(MOTW)", "OK", "ブロックのマークはありません", ""
    End If
End Sub

'======================================================================
' Declare文のDLL・関数を、実際に読み込めるか試す（管理者権限は不要）
'   LoadLibrary → GetProcAddress だけを行い、関数そのものは呼びません。
'   Windowsエラー番号の意味:
'     193  = ビット数の不一致（32bit用DLLを64bit版Excelで読もうとしている）
'     126  = DLLが見つからない（未インストール・パス違い・依存DLLなし）
'     5    = アクセス拒否（権限、またはセキュリティ設定によるブロック）
'     1260/1261/4551 = ポリシー（AppLocker・アプリ制御など）によるブロック
'     127  = DLLはあるが、その関数名がない（Alias名の誤り・APIが無い）
'======================================================================
Private Sub CollectDecl(ByVal modName As String, ByVal lineNo As Long, ByVal t As String)
    Dim ms As Object
    Dim mt As Object
    If mDecl Is Nothing Then Exit Sub
    Set ms = reDeclParts.Execute(t)
    For Each mt In ms
        mDecl.Add modName & "|" & lineNo & "|" & CStr(mt.SubMatches(1)) & "|" & CStr(mt.SubMatches(0)) & "|" & CStr(mt.SubMatches(2))
    Next mt
End Sub

Private Function DllErrText(ByVal code As Long) As String
    Select Case code
        Case 193
            DllErrText = "ビット数の不一致です（32bit用のDLLを64bit版Excelで読み込もうとしています）。64bit版のDLLが必要です"
        Case 126
            DllErrText = "DLLが見つかりません（未インストール、パスが違う、または依存するDLLが無い）"
        Case 5
            DllErrText = "アクセスが拒否されました（権限、またはセキュリティ設定によるブロックの可能性）"
        Case 1260, 1261, 4551
            DllErrText = "ポリシー（AppLocker・アプリ制御など）によってブロックされています。情報システム担当に確認してください"
        Case 127
            DllErrText = "DLLはありますが、その関数名が見つかりません（Alias名の誤り、またはAPIが無い・名前が違う）"
        Case 1114
            DllErrText = "DLLの初期化に失敗しました"
        Case Else
            DllErrText = "Windowsエラー " & code & "（DLLを読み込めませんでした）"
    End Select
End Function

Private Function CheckDllProc(ByVal lib As String, ByVal proc As String, ByRef state As String, ByRef code As Long) As Boolean
#If VBA7 Then
    Dim h As LongPtr
    Dim pa As LongPtr
#Else
    Dim h As Long
    Dim pa As Long
#End If
    code = 0
    h = LoadLibraryA(lib)
    If h = 0 Then
        code = Err.LastDllError
        state = "LOAD"
        Exit Function
    End If
    pa = GetProcAddress(h, proc)
    If pa = 0 Then pa = GetProcAddress(h, proc & "A")
    If pa = 0 Then
        code = Err.LastDllError
        state = "PROC"
    Else
        state = "OK"
        CheckDllProc = True
    End If
    FreeLibrary h
End Function

Private Sub TestDeclares()
    Dim ws As Worksheet
    Dim r As Long
    Dim i As Long
    Dim parts() As String
    Dim lib As String
    Dim proc As String
    Dim key As String
    Dim state As String
    Dim code As Long
    Dim ok As Boolean
    Dim cache As Collection
    Dim cached As String
    Dim nBad As Long
    Dim msg As String
    Dim lineNo As Long

    If mDecl Is Nothing Then Exit Sub
    If mDecl.Count = 0 Then Exit Sub
    Set cache = New Collection

    Set ws = ThisWorkbook.Worksheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
    ws.Name = "API読み込み_" & mStamp
    ws.Range("A1").Value = "Declare文のDLL・関数を、このPC（このExcel）で読み込めるかの試験結果（関数は呼んでいません）"
    ws.Range("A1").Font.Bold = True
    ws.Range("A3:G3").Value = Array("結果", "モジュール", "行", "DLL", "関数名(Alias)", "Windowsエラー", "意味・対処")
    ws.Range("A3:G3").Font.Bold = True
    ws.Range("A3:G3").Interior.Color = RGB(221, 235, 247)
    r = 4

    For i = 1 To mDecl.Count
        parts = Split(mDecl(i), "|")
        lib = parts(2)
        proc = parts(4)
        If Len(proc) = 0 Then proc = parts(3)
        lineNo = CLng(parts(1))
        key = LCase$(lib & "|" & proc)
        cached = ""
        On Error Resume Next
        cached = cache(key)
        Err.Clear
        On Error GoTo 0
        If Len(cached) = 0 Then
            If Left$(proc, 1) = "#" Then
                state = "SKIP"
                code = 0
            Else
                ok = CheckDllProc(lib, proc, state, code)
            End If
            cached = state & "|" & code
            cache.Add cached, key
        End If
        state = Split(cached, "|")(0)
        code = CLng(Split(cached, "|")(1))

        Select Case state
            Case "OK"
                msg = "読み込めました"
            Case "SKIP"
                msg = "序数指定（#番号）のため試験できません"
            Case Else
                msg = DllErrText(code)
        End Select

        If state = "OK" Then
            ws.Cells(r, 1).Value = "OK"
        ElseIf state = "SKIP" Then
            ws.Cells(r, 1).Value = "情報"
        Else
            ws.Cells(r, 1).Value = "NG"
        End If
        ws.Cells(r, 2).Value = "'" & parts(0)
        ws.Cells(r, 3).Value = lineNo
        ws.Cells(r, 4).Value = "'" & lib
        ws.Cells(r, 5).Value = "'" & proc
        If state = "LOAD" Or state = "PROC" Then ws.Cells(r, 6).Value = code
        ws.Cells(r, 7).Value = msg
        If state = "LOAD" Or state = "PROC" Then
            ws.Range(ws.Cells(r, 1), ws.Cells(r, 7)).Interior.Color = RGB(255, 199, 206)
            nBad = nBad + 1
            AddFinding "要修正", "Declare: DLL/関数を読み込めない", parts(0), lineNo, lib & " / " & proc & "  (Windowsエラー " & code & ")", msg
        End If
        r = r + 1
    Next i

    ws.Columns(1).ColumnWidth = 8
    ws.Columns(2).ColumnWidth = 22
    ws.Columns(3).ColumnWidth = 6
    ws.Columns(4).ColumnWidth = 28
    ws.Columns(5).ColumnWidth = 28
    ws.Columns(6).ColumnWidth = 14
    ws.Columns(7).ColumnWidth = 90

    If nBad = 0 Then
        AddFinding "情報", "Declare: DLL/関数の読み込み", "(全体)", 0, "試験した全てのDLL・関数を読み込めました", "ただし、ASRルール等による「呼び出し時」のブロックは、この試験では分かりません。RunEnvProbe で、API呼び出しが動くか確認してください"
    End If
End Sub

# 列挿入・列順の変更・行追加に強い列指定の書き方 ― IF判定を例に、テーブル設定の有無と後任者引き継ぎを考えて選択肢を整理した

# 列挿入・列順の変更・行追加に強い列指定の書き方 ― IF判定を例に、テーブル設定の有無と後任者引き継ぎを考えて選択肢を整理した

## 1. 背景

「この列に○○があったらIF」という判定を、C2:C10のように列記号と行番号を直打ちで書いていた。同じシート内の列挿入にはExcelが参照を追従させるが、元データの貼り替えで列の並びが変わったり、データが10行目を超えて増えたり、FILTERの結果のようにテーブル化できない表を扱ったりすると、この書き方は壊れる。エラーが出ればまだ気づけるが、別の列を参照したまま値が出ることもある。

引き継ぎ先の担当者には、なぜC列なのかが読み取れない。列を挿入してよいかも判断できない。そこで、見出し名で列を取る書き方を、テーブルの有無と引き継ぎの観点で整理した。

設例は次のとおり。

• 1行目が見出し、2〜11行目がデータ(10行)
• 「賞名」列は3列目(今はC列)
• 判定したいのは「賞名列に『金賞』があれば"あり"」
• 見出し名は変えないが、列挿入・行追加は今後ある

## 2. 選択肢

### 2-1. 列記号・行番号の直打ち

• やり方

- `=IF(COUNTIF(C2:C10,"金賞")>0,"あり","なし")`

• 新規・変更への対応

- 同じシート内の列挿入は、Excelが参照を自動調整する。
- 範囲の途中への行挿入も追従する。

• 弱点

- 元データの貼り替えや列順の変更には追従しない。
- 10行目の下に追加したデータは範囲に入らない。
- 後任者には、なぜC列なのか読み取れない。

### 2-2. シート全体から見出し名で列を取る(普通の範囲)

• やり方

- `=IF(COUNTIF(XLOOKUP("賞名",$1:$1,$1:$1048576),"金賞")>0,"あり","なし")`
- 数式内に説明を埋め込むなら、LETの未使用変数にメモを持たせる。
- `=LET(メモ,"賞名を見出し名で取得。列挿入OK",賞名列,XLOOKUP("賞名",$1:$1,$1:$1048576),IF(COUNTIF(賞名列,"金賞")>0,"あり","なし"))`

• 新規・変更への対応

- 列記号も行番号も書かないので、列挿入・列移動・行追加のすべてに強い。
- テーブル化できない既存表に、あとから使える。

• 弱点

- 見出しが1行目にある前提。見出し行の上に行を挿入すると外れる。
- シート全体を見るので、大量計算では少し重い。重いときは `$1:$5000` など大きめの固定行数にする。
- FILTERのスピル結果には使えない。

### 2-3. テーブル化して構造化参照で書く(テーブル名 T賞)

• やり方

- `=IF(COUNTIF(T賞[賞名],"金賞")>0,"あり","なし")`
- テーブル内で行ごとに判定するなら `=IF([@賞名]="金賞","対象","")`

• 新規・変更への対応

- 列挿入・列移動・行追加のすべてに自動で追従する。
- 見出しとデータが同じ構造なので、ずれが原理的に起きない。
- 式に列名がそのまま見えるので、後任者が迷わない。

• 弱点

- テーブル化できる表でないと使えない。FILTERの結果はテーブルにできない。

### 2-4. FILTER結果を、見出しとデータの別々のスピルで出す

• やり方

- A1に見出し: `=T賞[#Headers]`
- A3にデータ: `=FILTER(T賞,T賞[年度]=2026,EXPAND("",1,COLUMNS(T賞),""))`
- 判定: `=IF(COUNTIF(XLOOKUP("賞名",$A$1#,$A$3#),"金賞")>0,"あり","なし")`
- FILTERの第3引数(0件のときの値)に、`EXPAND("",1,COLUMNS(T賞),"")` で「元表と同じ列数の空白1行」を渡す。0件でも列数が崩れず、エラーにならない。

• 新規・変更への対応

- 元表に列を挿入すると、見出しもデータも一緒に増えて追従する。
- `COLUMNS(T賞)` も列数に追従するので、0件時の空白行の幅も自動で合う。
- 式が短く、列名で読める。

• 弱点

- 見出しとデータの列が一致する保証が、人の作業に依存する。データ側だけCHOOSECOLSで列を絞った場合などにずれる。この場合、第3引数のEXPANDも同じ列数に合わせる必要がある。
- 列数が違えば#VALUE!で気づけるが、同数の列が入れ替わるずれはエラーにならず、静かに間違う。
- 0件のとき、空白1行が出る。行数を数える後続処理では、その1行を除外する。

• 引き継ぎ(前任者)

- 見出しとデータの元を同じテーブルにする。
- 一致チェックのセルを置く: `=IF(COLUMNS($A$1#)=COLUMNS($A$3#),"列数OK","列数NG")`
- A1・A3のセルにメモ(コメント)を付ける。例: 「A1=見出し、A3=抽出結果。元は同じ。列名で取るので列挿入OK」

• 引き継ぎ(後任者)

- A1とA3の数式を見て、起点が同じ表だと確認する。
- 列を絞っていれば、両方が同じ絞り方か、EXPANDの列数も合っているか確認する。

### 2-5. FILTER結果を、VSTACKで見出しごと1つのスピルにする

• やり方

- A1: `=VSTACK(T賞[#Headers],FILTER(T賞,T賞[年度]=2026,EXPAND("",1,COLUMNS(T賞),"")))`
- A2はスピルの起点ではないので `$A$2#` は使えない。判定のたびにTAKE/DROPで分ける。
- `=LET(メモ,"VSTACKで見出しごと取得。賞名を見出し名で探す。列挿入OK",全体,$A$1#,見出し,TAKE(全体,1),データ,DROP(全体,1),IF(COUNTIF(XLOOKUP("賞名",見出し,データ),"金賞")>0,"あり","なし"))`
- 0件対策は2-4と同じく、FILTERの第3引数にEXPANDで列数ぶんの空白行を渡す。`FILTER(…,条件,"")` だと空文字が1列になって列数が合わなくなるが、EXPANDなら合う。

• 新規・変更への対応

- 見出しとデータが同じスピルなので、ずれが構造的に起きない。
- 起点が1つだと確認できれば、前任者の作業を信用しなくてよい。

• 弱点

- 簡単なIFのたびにTAKE/DROPが入り、式が長くなる。後任者にTAKE/DROPの知識が要る。
- 0件のとき、見出しの下に空白1行が残る。

### 2-6. 2-5の複雑さを「名前の定義」に隠す

• やり方

- 数式タブ → 名前の管理 → 新規で、名前を `賞名列` として次を登録する。
- `=LET(全体,Sheet1!$A$1#,XLOOKUP("賞名",TAKE(全体,1),DROP(全体,1)))`
- 名前の「コメント」欄に「VSTACKで見出しごと取っている。見出し名で列を探す。列挿入OK」と書く。
- セル側は `=IF(COUNTIF(賞名列,"金賞")>0,"あり","なし")` だけで済む。

• 新規・変更への対応

- 2-5の堅さをそのまま保ちつつ、日常の式は2-3とほぼ同じ見た目になる。
- 別の列が必要なら、名前をコピーして見出し名だけ変える(例: 氏名列)。

• 弱点

- 名前の中身はセルから見えない。後任者は名前の管理を開く必要がある。
- コメントを書き忘れると、2-5より読み解きにくくなる。

### 2-7. どの方式にも付ける補強(引き継ぎのコツ)

• 一言メモを残す

- 「列名で取っている。列挿入OK」と一言あるだけで、後任者は列を挿入していいか迷わない。
- 置き場所は3つ。セルのメモ、名前の管理のコメント欄、LETの未使用変数(`メモ,"…"`)。数式そのものに説明が残るのはLETのメモ変数だけで、セルのコピーや移動でも消えない。

• 一致チェックのセルを置く

- 別スピル(2-4)では必須。`COLUMNS` の一致で、見出しとデータの幅のずれを検知する。

• 見出し名の完全一致を保つ

- 全角・半角や前後の空白の違いは#N/Aの原因。見出し名は変えない前提を、メモに書いておく。

• 0件時の挙動を決めて書く

- FILTERの第3引数に `EXPAND("",1,COLUMNS(元表),"")` を渡し、「0件でも列数は保つ。空白1行が出る」とメモする。

• 判定式を、参照している列自体に置かない(循環参照になる)。

### 2-8. スピルの結果を、他の数式から読まない設計にする

• 考え方

- 見出しとデータのずれは、スピルの結果を別の数式から位置で読むときに起きる。読まない設計にすれば、ずれ自体が起きない。
- 用語を次のとおり使い分ける。
- 読取元: FILTERが参照するテーブル(例: T賞)。
- 書込先: 数式を置くテーブルの列。

• やり方

- 書込先の列に、読取元の列を引数にしたFILTERを書く。その数式の中で、TEXTJOINやCOUNTIFSを使って1セルに畳む。
- `=TEXTJOIN("、",TRUE,FILTER(T賞[氏名],T賞[賞ID]=[@賞ID],""))`
- 行ごとに、同じ賞IDの氏名を1セルに連結する形になる。
- 一覧が見たいときは、スピルをテーブルの外に確認用として置く。他の数式からはその結果を参照しない。

• 新規・変更への対応

- FILTERの引数に列名が入るので、列挿入・列移動に追従する。
- スピルが他の数式から読まれないので、見出しとのずれが起きない。
- 書込先がテーブルなので、行の追加にも追従する。

• 弱点

- 1セルに畳めることが条件。複数列を同時に返したい場合や、後続の集計で行ごとの明細が要る場合は使えない。
- 畳む関数(TEXTJOINなど)の知識が後任者に要る。

## 3. 評価軸

• A. 列挿入・列移動に追従する
• B. 行の追加・増減に追従する
• C. 見出しとデータのずれが構造的に起きない
• D. 後任者が読めて、引き継ぎの手間が小さい

凡例: ○=満たす / △=条件付き / ×=満たさない

## 4. 比較

2-1 直打ち(C2:C10)**

• A 列挿入・列移動に追従する: △(同シート内の挿入のみ。列順の変更や貼り替えは×)
• B 行の追加・増減に追従する: △(範囲内への挿入のみ。10行目の下は範囲外)
• C 見出しとデータのずれが構造的に起きない: ×(見出しを見ていない)
• D 後任者が読めて、引き継ぎの手間が小さい: ×(なぜC列なのか読み取れない)
• 備考: エラーにならず静かに間違うのが最大のリスク

2-2 シート全体から見出し名で取る**

• A 列挿入・列移動に追従する: ○
• B 行の追加・増減に追従する: ○
• C 見出しとデータのずれが構造的に起きない: ○(同じ表の見出し行を見ている)
• D 後任者が読めて、引き継ぎの手間が小さい: ○(LETのメモ変数で説明を埋め込める)
• 備考: 見出し行の上に行を挿入すると外れる。FILTERのスピル結果には使えない

2-3 テーブル構造化参照**

• A 列挿入・列移動に追従する: ○
• B 行の追加・増減に追従する: ○
• C 見出しとデータのずれが構造的に起きない: ○
• D 後任者が読めて、引き継ぎの手間が小さい: ○(式に列名がそのまま見える)
• 備考: 使えるなら迷わずこれ。FILTER結果はテーブル化できない

2-4 FILTER・別スピル**

• A 列挿入・列移動に追従する: ○
• B 行の追加・増減に追従する: ○
• C 見出しとデータのずれが構造的に起きない: △(人の作業に依存。同数の列が入れ替わるずれは静かに間違う)
• D 後任者が読めて、引き継ぎの手間が小さい: ○(式は短い。ただし一致チェックと引き継ぎメモが前提)
• 備考: 式は一番きれい。0件はEXPANDで対応済み。後任者はA1とA3の起点が同じ表か確認が必要

2-5 FILTER・VSTACK**

• A 列挿入・列移動に追従する: ○
• B 行の追加・増減に追従する: ○
• C 見出しとデータのずれが構造的に起きない: ○(同じスピルなので構造的に起きない)
• D 後任者が読めて、引き継ぎの手間が小さい: △(簡単なIFのたびにTAKE/DROPが入り、式が長い)
• 備考: 一番堅い。0件はEXPANDで対応済み(空白1行が残る)

2-6 FILTER・VSTACK＋名前定義**

• A 列挿入・列移動に追従する: ○
• B 行の追加・増減に追従する: ○
• C 見出しとデータのずれが構造的に起きない: ○
• D 後任者が読めて、引き継ぎの手間が小さい: ○(日常の式は短い。名前の中身は名前の管理で別確認。コメント欄が前提)
• 備考: 堅さと式の短さの両立に最も近い。名前のコメント欄に説明を残す

2-8 スピルを他の数式から読まない(FILTERを数式内で1セルに畳む)**

• A 列挿入・列移動に追従する: ○
• B 行の追加・増減に追従する: ○
• C 見出しとデータのずれが構造的に起きない: ○(スピルを読まないので、ずれる対象がない)
• D 後任者が読めて、引き継ぎの手間が小さい: ○(式に列名が見える。TEXTJOINなどの知識は要る)
• 備考: 1セルに畳める場合に限る。複数列の返却や、行ごとの明細が要る場合は2-4〜2-6を使う

## 5. 結論

テーブル化できるなら、2-3が全項目を満たす。迷ったらこれだ。

問題はFILTERの結果のように、テーブル化できない表だ。ここでは「式の短さ」と「ずれの起きにくさ」が両立しない。別スピル(2-4)は式がきれいだが、見出しとデータの一致を人の作業で守ることになる。VSTACK(2-5)は構造的に安全だが、式が長くなる。名前の定義(2-6)で複雑さを隠せば両立に近づくが、中身がセルから見えなくなる代わりに、名前の管理を確認する手間が後任者に生じる。

ただし、判定を1セルに畳めるなら、そもそもスピルを他の数式から読む必要がない。2-8は、読取元をテーブルにし、書込先の列でFILTERを使って畳むので、見出しとのずれが起きず、式も単純になる。2-4〜2-6が必要になるのは、抽出結果を列単位で別の数式から参照したいときだけだ。

なお、0件時のエラーはFILTERの第3引数にEXPANDで列数ぶんの空白行を渡せば解消できる。方式の優劣を左右するのは、エラー対応ではなく、ずれの検知と引き継ぎの手間のほうだ。

つまり、すべてを満たす方法はなく、「堅さ」「読みやすさ」「確認の手間」のどれを引き継ぎ先に払わせるかの選択になる。どの方式でも、一言メモを残す補強(2-7)で、その手間はかなり下げられる。

## 6. 判断の軸

1. 判定を1セルに畳める(抽出結果を他の数式から読まなくてよい) → 2-8
2. 表をテーブル化できる → 2-3
3. テーブル化できない普通の範囲で、見出しが1行目に固定 → 2-2
4. FILTER結果を列単位で参照する必要があり、堅さを最優先したい、または後任者に確認を期待できない → 2-6(複雑さは名前に隠す)
5. FILTER結果を列単位で参照する必要があり、式の読みやすさを優先し、一致チェックのセルと引き継ぎメモを必ず置ける → 2-4
6. FILTER結果を列単位で参照する必要があり、名前の定義を使いたくない → 2-5(式が長くなるのを受け入れる)

## 7. 今回の判断と切り替え方針

FILTERで抜いた表を後任者に引き継ぎ、抽出結果を列単位で別の数式から参照する前提なので、2-6(VSTACK＋名前定義)を選ぶ。見出しとデータの起点が1つに固まるため、後任者が「前任者は列を合わせて書いたはず」と信じる必要がない。確認するのは、名前の管理にある参照先と、A1の数式にVSTACKとFILTERが両方入っていること、そしてコメント欄の一言メモだけだ。

条件が変わったら、方針を切り替える。

• 判定を1セルに畳めるようになった → 2-8に寄せる
• 元の表をテーブルのまま使えるようになった → 2-3に戻す
• 抽出する列や条件が増え、FILTERの式が複雑になってきた → Power Queryで抽出し、結果をテーブルとして出力する
• 後任者がVSTACK/TAKE/DROPに不慣れで、名前の定義も読まれない → 2-4に寄せ、一致チェックのセルとメモで補う

どの方式でも、後任者が最初に確認することは同じだ。「見出しの出どころ」と「データの出どころ」が、同じ表かどうか。

tidy data (Wickham)のわかりやすい説明
整然データ(tidy data)とは | IT工房｜AI入門とWeb開発｜エンジニアのグルメ日記

# Excelで「生データから必要な列だけ持ってくる」中間テーブル設計の取捨選択

# Excelで「生データから必要な列だけ持ってくる」中間テーブル設計の取捨選択

業務システムから出力される列数の多い生データから、作業に必要な列だけを抜き出して中間テーブルを作る。定型的な作業のはずなのに、スピルとテーブルの相性の悪さでつまずいたので、選択肢を整理した。

## 背景:XLOOKUPで列ごと引くのは便利だが、スピルする

作業表の1行目に必要な見出しを書き、生データの見出し行から引く形は、次の1本で書ける。

`=XLOOKUP(見出し, 生データの見出し行, 生データの本体)`

検索範囲が横(見出し行)なので、一致した列が縦にスピルする。列が挿入・移動されても見出しで追従し、元データを変えた瞬間に再計算される。

ただし、テーブル内のセルにはスピルする数式を入れられない。ここでスピルとテーブルが衝突する。

## スピル以前は、新しい・変更された生データにどう対応していたか

「生データが入れ替わる、行数や列構成が変わる」ことへの対応は、昔から次のような方法があった。

1. 配列数式(INDEX+MATCH)**

• やり方: `INDEX(表本体, 0, MATCH(見出し, 見出し行, 0))` を、返す行数ぶんの範囲を選んで Ctrl+Shift+Enter で入力する
• 新規・変更データへの対応: 見出しで列を選ぶので列位置の変更には強い
• 弱点: 範囲を事前に選ぶ必要があり、行数の増減には追従しない。多いと#N/A、少ないと切れる

2. 全セルに「=」の参照式を余裕をもって埋めておく**

• やり方: 想定最大行数(例: 5,000行)ぶん、`=IFERROR(INDEX(...),"")` や `=原本!C2` のような式を先に埋めておく
• 新規・変更データへの対応: 原本を貼り替えれば、式はそのまま新データを拾う。行数が増減しても空白表示で吸収できる
• 弱点: 想定を超えた行数で切れる。式が大量で重くなる。空白の「""」が値として残り、集計や後続処理で邪魔になる

3. VLOOKUP/HLOOKUP/INDEX+MATCHを1セルずつ並べる**

• やり方: 1セルを返す関数を、行方向・列方向にコピーして並べる
• 新規・変更データへの対応: 列位置はMATCHで吸収できるが、行数の増減に合わせて式のコピー範囲を自分で調整する
• 弱点: 方式2と同じく過不足の管理が必要。VLOOKUP/HLOOKUP単体では列全体を一度に返せない

4. 動的な名前付き範囲(OFFSET/INDEX+COUNTA)**

• やり方: データ行数を数えて範囲の大きさが自動で変わる名前を定義し、数式から参照する
• 新規・変更データへの対応: 行数の増減に追従できる
• 弱点: OFFSETは揮発性関数で重い。名前の定義が見えにくく、作った本人以外には読み解きにくい

5. マクロ(VBA)で取り込み・整形する**

• やり方: 取り込みマクロが作業列を初期化し、原本を所定の位置に貼り、見出しに合わせて必要列だけ書き出す。行数ぶんの式のコピーもマクロが行う
• 新規・変更データへの対応: 最も柔軟。見出し照合、列位置の調整、行数に応じた範囲設定まで自動化できる
• 弱点: 値貼り付けなら元データに追従しない(取り込みのたびに実行が必要)。マクロを書ける人に依存し、属人化しやすい

6. 原本の置き場所を固定し、右側に加工列を作り込む**

• やり方: 業務システムからの出力を貼る場所をシートの左側に固定し、右側に数式を作り込む。取り込みごとに日付付きの新ファイルへ切り出す
• 新規・変更データへの対応: 貼り替えだけで済む。列が増えたときは過去ファイルから復元して位置を調整する
• 弱点: 列構成の変更に気づくのが遅れると、後続の成果物まで影響が及ぶ。原本と加工が同じシートに同居する

7. フィルターや列の非表示で、必要な列だけ見せる**

• やり方: 必要列以外を非表示にする、またはオートフィルターで行を絞る
• 新規・変更データへの対応: 原本の貼り替えには強いが、列構成が変わると非表示の設定がずれる
• 弱点: 「持ってくる」のではなく「隠す」だけなので、別の表として使うには結局コピーが必要

8. ユーザー設定のビュー**

• やり方: 列の非表示・フィルター・印刷設定などの組み合わせを名前を付けて保存し、切り替える
• 新規・変更データへの対応: 同じ見せ方に戻すのは簡単だが、列構成が変わると保存したビューがずれる
• 弱点: ブック内にテーブルがあると使えなくなる。表示を切り替えるだけで、データの抽出や加工はできない

9. 外部データの取り込み(旧来のデータ接続、テキストファイルのクエリ、MS Query など)**

• やり方: CSVやデータベースへの接続を作り、必要な列だけ取り込む。「更新」で再取り込みする
• 新規・変更データへの対応: 更新操作で最新データを読み直せる。列の選択は接続側で行う
• 弱点: 更新操作が必要。整形や結合の自由度が低く、設定が分かりにくい

10. ピボットテーブルで必要な列だけ集める**

• やり方: 元データをピボットの元にして、必要なフィールドだけ配置する
• 新規・変更データへの対応: 元範囲をテーブルにしておけば行数の増加に追従する。更新操作は必要
• 弱点: 集計向きで、明細をそのまま並べる用途には使いにくい

11. Power Query(2010以降のアドイン、2016以降は標準)**

• やり方: 原本を読み込み、必要な列を選び、マスタとマージして、結果をテーブルに出力する
• 新規・変更データへの対応: 更新操作で最新化できる。列は見出しで選べ、型変換や不要行の除去も同じ手順に組み込める
• 弱点: 更新操作が必要。元データの列名変更には弱い

これらの方法は、「行数の増減にどこまで追従できるか」「列構成の変更を誰が吸収するか」「更新を自動にするか手動にするか」で性格が分かれる。スピル+XLOOKUPは、これらの問題を数式1本で解決した点が大きい。

## 4つの要求

• A. 原本を汚さない
• B. 更新に自動追従する
• C. 中間をテーブル化する(後続の参照式が列名で書け、行の増加にも追従する)
• D. 作り込みや運用の手間を小さくする

## 各案の比較

凡例: ○=満たす / △=条件付き / ×=満たさない

XLOOKUPスピル**

• A 原本を汚さない: ○
• B 自動追従: ○(即時)
• C テーブル: ×(`A2#` で代替)
• 備考: 更新の押し忘れ事故がない

Power Query**

• A 原本を汚さない: ○
• B 自動追従: △(更新操作が必要)
• C テーブル: ○
• 備考: 原本とマスタのマージ向き。定型業務の標準解

行ごとのINDEX+MATCH**

• A 原本を汚さない: ○
• B 自動追従: ○
• C テーブル: ○
• 備考: 数式が重く、読みにくい

原本テーブルの右隣に加工列**

• A 原本を汚さない: ×
• B 自動追従: ○
• C テーブル: ○
• 備考: 手間が最小。貼り替え手順の管理が必要

作業シートにコピー/参照**

• A 原本を汚さない: ○
• B 自動追従: コピーは×、参照はスピル化
• C テーブル: 参照はテーブル不可
• 備考: 結局スピルとテーブルの衝突に戻る

VBAで値を貼り付け**

• A 原本を汚さない: ○
• B 自動追従: ×(値貼り付けのため追従しない)
• C テーブル: ○
• 備考: 取り込み自体は自動化できる

## 結論:三拍子は揃わない

「原本を汚さない」「自動追従」「テーブル」を、Excelの数式だけで同時に満たす手段はない。スピルは1つの数式が周囲のセルを占有し、テーブルは各セルが独立した領域であることを前提とするため、構造上両立しない。

Power Queryはこの3つに最も近いが、更新はクエリの再実行という別系統で動くため、同じブック内のシートが元でも自動追従しない。「ファイルを開くとき更新」やVBAで自動化はできるが、即時反映ではない。

## 判断の軸

1. 更新操作を許容できる → Power Query(原本は不変、出力はテーブル)
2. 更新操作は許容できないが、テーブルを諦められる → スピル
3. 後続の作り込みが多く、テーブルが必須 → 原本テーブルの右隣に加工列を足す

## 「汚す」を選ぶときの補強策

右隣に加工列を足す方式は、昔ながらの業務シートの定番でもある。システムからの出力を貼る場所を左側に固定し、右側に作り込んだ数式を置く。テーブルの計算列と組み合わせれば、旧来の弱点だった「行数が変わったときの数式の伸ばし忘れ」も解消できる。

運用上の注意は次のとおり。

• 取り込み時は、原本列の中身だけを初期化してから貼る(加工列には触らない)
• 貼る前に見出しの一致を確認する(列数や列順が変わると貼り付け位置がずれる)
• 取り込みごとに日付付きで原本を別名保存し、復元元を残す
• 原本側と加工側の境目を、見出しの色や列の間隔で見分けられるようにする

日付ごとに新しいファイルへ切り出す運用なら、列構成が変わっても過去ファイルから復元・調整できる。変更の「事前検知」ではなく「事後に直せる体制」で担保する考え方で、シンプルに回せる。弱点は、気づくのが遅れると後続の成果物まで影響が及ぶ点。

## 今回の判断

更新が入る生データが1つ、マスタが少数、後続の作り込みが多い。この条件ではテーブルの恩恵を最優先にし、生データの横にマスタ参照列を足す方式を選んだ。これは合理的だった。

条件が変わったら、方針を切り替える。

• 原本が複数になる
• マスタが増えていく
• 毎回同じ手順を繰り返す

この場合は、Power Queryで原本とマスタをマージし、中間テーブルをテーブルとして出力する形に寄せる。

エクセル ヘッダーフッター設定日時とファイルパスを設定したら除去したりchatGpt

————————

Option Explicit

'==================================================
' アクティブシート
'==================================================
Sub HF_アクティブシートのヘッダーフッターを設定・削除()

    Dim ws As Worksheet

    ' 現在の設定
    Dim strCurrentHeaderLeft As String
    Dim strCurrentHeaderCenter As String
    Dim strCurrentHeaderRight As String
    Dim strCurrentFooterLeft As String
    Dim strCurrentFooterCenter As String
    Dim strCurrentFooterRight As String

    ' 設定する内容
    Dim strTargetHeaderRight As String
    Dim strTargetFooterLeft As String

    ' 表示用
    Dim strMessage As String
    Dim strCurrent As String
    Dim strAfter As String

    Dim intAnswer As VbMsgBoxResult
    Dim strOperation As String

    Set ws = ActiveSheet

    ' 設定する内容
    strTargetHeaderRight = "&[日付]　&[時刻]"

    strTargetFooterLeft = _
        "保存先：&[パス]" & vbLf & _
        "ファイル名：&[ファイル]" & vbLf & _
        "シート名：&[シート]"

    ' 現在の設定を取得
    With ws.PageSetup

        strCurrentHeaderLeft = .LeftHeader
        strCurrentHeaderCenter = .CenterHeader
        strCurrentHeaderRight = .RightHeader

        strCurrentFooterLeft = .LeftFooter
        strCurrentFooterCenter = .CenterFooter
        strCurrentFooterRight = .RightFooter

    End With

    ' 両方空なら設定、それ以外なら削除
    If strCurrentHeaderRight = "" And _
       strCurrentFooterLeft = "" Then

        strOperation = "設定"

    Else

        strOperation = "削除"

    End If

    ' 現在の設定
    strCurrent = _
        "【現在の設定】" & vbCrLf & _
        vbCrLf & _
        "ヘッダー" & vbCrLf & _
        "左上：" & strCurrentHeaderLeft & vbCrLf & _
        "中央：" & strCurrentHeaderCenter & vbCrLf & _
        "右上：" & strCurrentHeaderRight & vbCrLf & _
        vbCrLf & _
        "フッター" & vbCrLf & _
        "左下：" & strCurrentFooterLeft & vbCrLf & _
        "中央：" & strCurrentFooterCenter & vbCrLf & _
        "右下：" & strCurrentFooterRight

    ' 変更後の設定
    If strOperation = "設定" Then

        strAfter = _
            "【変更後の設定】" & vbCrLf & _
            vbCrLf & _
            "ヘッダー" & vbCrLf & _
            "左上：" & strCurrentHeaderLeft & vbCrLf & _
            "中央：" & strCurrentHeaderCenter & vbCrLf & _
            "右上：" & strTargetHeaderRight & vbCrLf & _
            vbCrLf & _
            "フッター" & vbCrLf & _
            "左下：" & strTargetFooterLeft & vbCrLf & _
            "中央：" & strCurrentFooterCenter & vbCrLf & _
            "右下：" & strCurrentFooterRight

        strMessage = _
            "【設定】" & vbCrLf & _
            "ヘッダー右上とフッター左下を上書きします。" & vbCrLf & _
            vbCrLf & _
            strCurrent & vbCrLf & _
            vbCrLf & _
            strAfter & vbCrLf & _
            vbCrLf & _
            "上書きしますか？"

    Else

        strAfter = _
            "【変更後の設定】" & vbCrLf & _
            vbCrLf & _
            "ヘッダー" & vbCrLf & _
            "左上：" & strCurrentHeaderLeft & vbCrLf & _
            "中央：" & strCurrentHeaderCenter & vbCrLf & _
            "右上：" & vbCrLf & _
            vbCrLf & _
            "フッター" & vbCrLf & _
            "左下：" & vbCrLf & _
            "中央：" & strCurrentFooterCenter & vbCrLf & _
            "右下：" & strCurrentFooterRight

        strMessage = _
            "【削除】" & vbCrLf & _
            "ヘッダー右上とフッター左下を削除します。" & vbCrLf & _
            vbCrLf & _
            strCurrent & vbCrLf & _
            vbCrLf & _
            strAfter & vbCrLf & _
            vbCrLf & _
            "削除しますか？"

    End If

    ' 確認
    intAnswer = MsgBox( _
        strMessage, _
        vbYesNo + vbQuestion, _
        "ヘッダー・フッター確認")

    If intAnswer = vbYes Then

        With ws.PageSetup

            If strOperation = "設定" Then

                .RightHeader = strTargetHeaderRight
                .LeftFooter = strTargetFooterLeft

            Else

                .RightHeader = ""
                .LeftFooter = ""

            End If

        End With

        MsgBox "完了", _
               vbInformation, _
               "ヘッダー・フッター"

    Else

        MsgBox "キャンセルしました", _
               vbInformation, _
               "ヘッダー・フッター"

    End If

End Sub


'==================================================
' 全シート
'==================================================
Sub HF_全シートのヘッダーフッターを設定・削除()

    Dim wb As Workbook
    Dim ws As Worksheet

    Dim intSheetCount As Long
    Dim blnAllEmpty As Boolean

    ' 設定する内容
    Dim strTargetHeaderRight As String
    Dim strTargetFooterLeft As String

    Dim strMessage As String
    Dim intAnswer As VbMsgBoxResult

    Set wb = ActiveWorkbook

    ' 設定する内容
    strTargetHeaderRight = "&[日付]　&[時刻]"

    strTargetFooterLeft = _
        "保存先：&[パス]" & vbLf & _
        "ファイル名：&[ファイル]" & vbLf & _
        "シート名：&[シート]"

    ' シート数
    intSheetCount = wb.Worksheets.Count

    ' 全シートの対象箇所が空か確認
    blnAllEmpty = True

    For Each ws In wb.Worksheets

        If ws.PageSetup.RightHeader <> "" Or _
           ws.PageSetup.LeftFooter <> "" Then

            blnAllEmpty = False
            Exit For

        End If

    Next ws

    ' 確認メッセージ
    If blnAllEmpty Then

        strMessage = _
            "【全シート設定】" & vbCrLf & _
            vbCrLf & _
            "アクティブブックの全" & intSheetCount & "シートについて、" & vbCrLf & _
            "ヘッダー右上とフッター左下を" & vbCrLf & _
            "以下の内容に上書きします。" & vbCrLf & _
            vbCrLf & _
            "ヘッダー右上：" & vbCrLf & _
            strTargetHeaderRight & vbCrLf & _
            vbCrLf & _
            "フッター左下：" & vbCrLf & _
            strTargetFooterLeft & vbCrLf & _
            vbCrLf & _
            "全シートに設定しますか？"

    Else

        strMessage = _
            "【全シート削除】" & vbCrLf & _
            vbCrLf & _
            "アクティブブックの全" & intSheetCount & "シートから、" & vbCrLf & _
            "ヘッダー右上とフッター左下を削除します。" & vbCrLf & _
            vbCrLf & _
            "全シートから削除しますか？"

    End If

    ' 確認
    intAnswer = MsgBox( _
        strMessage, _
        vbYesNo + vbQuestion, _
        "ヘッダー・フッター確認")

    If intAnswer <> vbYes Then

        MsgBox "キャンセルしました", _
               vbInformation, _
               "ヘッダー・フッター"

        Exit Sub

    End If

    ' 全シートに適用
    For Each ws In wb.Worksheets

        With ws.PageSetup

            If blnAllEmpty Then

                .RightHeader = strTargetHeaderRight
                .LeftFooter = strTargetFooterLeft

            Else

                .RightHeader = ""
                .LeftFooter = ""

            End If

        End With

    Next ws

    MsgBox "完了", _
           vbInformation, _
           "ヘッダー・フッター"

End Sub

————————

————————

————————

————————

————————

複数グループから提出されたものに、通し番号を付与して50件ずつ束を作成する。

1目的

2コード

Option Explicit

'============================================================
' モジュール名
'   mod提出物採番して外注束作成
'
' Version
'   1.1
'
'【目的】
' 読取シートへ入力した会社ごとの提出件数を、
' 50件単位の外注束へ展開して出力シートへ出力する。
'
'【設計方針】
' ・シートレイアウトはExcel側で管理する。
' ・見出し・書式・列幅はVBAで変更しない。
' ・VBAはデータのみ出力する。
' ・読取順に処理する。
' ・変数は初めて意味を持つブロックで宣言する。
' ・コメントは処理の区切りと、コードだけでは伝わらない
'   設計意図のみ記述する。
'============================================================

Private Enum cNoWs読取
    会社名 = 1
    件数 = 2
End Enum

Private Enum cNoWs出力
    ID = 1
    会社名 = 2
    件数 = 3
    束番号 = 4
    開始番号 = 5
    終了番号 = 6
End Enum

Sub 出力作成()

    '======== 定数 ========

    Const 最大束件数 As Long = 50

    Const 読取シート名 As String = "入力"
    Const 出力シート名 As String = "出力"

    Const 読取開始行 As Long = 2
    Const 出力開始行 As Long = 2

    '======== シート取得 ========

    Dim ws読取 As Worksheet
    Dim ws出力 As Worksheet

    Set ws読取 = Worksheets(読取シート名)
    Set ws出力 = Worksheets(出力シート名)

    '======== 出力シート初期化 ========

    ws出力.Rows(出力開始行 & ":" & ws出力.Rows.Count).ClearContents

    '======== 採番初期化 ========

    Dim lng現在束番号 As Long
    Dim lng現在束残件数 As Long
    Dim lng次開始番号 As Long
    Dim lng次行ID As Long
    Dim rNo出力行 As Long

    lng現在束番号 = 1
    lng現在束残件数 = 最大束件数
    lng次開始番号 = 1
    lng次行ID = 1
    rNo出力行 = 出力開始行

    '======== 読取データを順番に処理 ========

    Dim rNo読取最終行 As Long
    Dim rNo読取行 As Long

    rNo読取最終行 = ws読取.Cells(ws読取.Rows.Count, cNoWs読取.会社名).End(xlUp).Row

    For rNo読取行 = 読取開始行 To rNo読取最終行

        Dim str会社名 As String
        Dim lng会社残件数 As Long

        str会社名 = ws読取.Cells(rNo読取行, cNoWs読取.会社名).Value
        lng会社残件数 = ws読取.Cells(rNo読取行, cNoWs読取.件数).Value

        '会社より50件単位を優先して束を構成する
        Do While lng会社残件数 > 0

            '======== 今回出力件数を決定 ========

            Dim lng今回出力件数 As Long

            If lng会社残件数 <= lng現在束残件数 Then
                lng今回出力件数 = lng会社残件数
            Else
                lng今回出力件数 = lng現在束残件数
            End If

            '======== 開始番号・終了番号を決定 ========

            Dim lng終了番号 As Long

            lng終了番号 = lng次開始番号 + lng今回出力件数 - 1

            '======== 出力 ========

            ws出力.Cells(rNo出力行, cNoWs出力.ID).Value = lng次行ID
            ws出力.Cells(rNo出力行, cNoWs出力.会社名).Value = str会社名
            ws出力.Cells(rNo出力行, cNoWs出力.件数).Value = lng今回出力件数
            ws出力.Cells(rNo出力行, cNoWs出力.束番号).Value = lng現在束番号

            ws出力.Cells(rNo出力行, cNoWs出力.開始番号).Value = lng次開始番号
            ws出力.Cells(rNo出力行, cNoWs出力.終了番号).Value = lng終了番号

            '======== 状態更新 ========

            lng会社残件数 = lng会社残件数 - lng今回出力件数
            lng現在束残件数 = lng現在束残件数 - lng今回出力件数

            lng次開始番号 = lng終了番号 + 1

            lng次行ID = lng次行ID + 1
            rNo出力行 = rNo出力行 + 1

            If lng現在束残件数 = 0 Then
                lng現在束番号 = lng現在束番号 + 1
                lng現在束残件数 = 最大束件数
            End If

        Loop

    Next rNo読取行

    '======== 完了 ========

    MsgBox "出力が完了しました。"

End Sub

以下claude版

 

Option Explicit

'============================================================
' モジュール名
'   mod提出物採番して外注束作成
'
' Version
'   2.9
'
'【目的】
' 読取シートへ入力した会社ごとの提出件数を、
' 50件単位の外注束へ展開して出力シートへ出力する。
'
'【設計方針】
' ・シートレイアウトはExcel側で管理する。
' ・見出し・書式・列幅はVBAで変更しない。
' ・VBAはデータのみ出力する。
' ・読取順に処理する。
' ・変数は初めて意味を持つブロックで宣言する。
' ・役割（書込み先／読取り元）が異なる行番号は、たとえ同じシートを
'   指していても変数を使い回さず、別の変数名として書き分ける。
' ・行番号変数は「RNo_シート名_役割」の形式で命名し、
'   どのシートのどの用途の行番号かを本文だけで判別できるようにする。
' ・データ値の変数も同様に「型_ws_シート名_列名（用途）」の形式で
'   命名し、どのシートのどの列に対応する値かを本文だけで
'   判別できるようにする。
'
'【コメント方針】
' ・コメントは処理の区切り（ステップの節目）や、コードだけでは
'   伝わらない設計意図・判断理由を記述する。
' ・特に、複数の判定や処理が連続していて、それぞれが何をしているか
'   一目で分からない箇所（連続するIf文、If-Elseの分岐など）や、
'   ループ・変数宣言・分岐の直前など、コードだけでは目的が
'   伝わりにくい箇所には、一言添える。
' ・変数名や条件式自体が文として読める箇所は、コメントがなくても
'   読み下せることが多いが、他の判断基準を優先してよい。
'
'【出力の粒度について】
' ・「束」は読取順の通し番号に対して50件ごとに機械的に区切られる
'   （会社の境界は一切考慮しない）。
' ・出力シートの1行は「束まるごと」ではなく「束×会社」の単位になる。
'   1つの束に複数社が含まれる場合や、1社が複数束にまたがる場合は、
'   会社が変わる箇所・束が変わる箇所のどちらでも行を分ける。
'
'【採番方式について】
' ・通し番号・束番号・束内番号は、いずれも割り算や逆算によらず、
'   作業シートへの展開と同時にカウンタを1件ずつ加算（必要に応じて
'   リセット）することで採番する。
' ・開始番号・終了番号は、束内番号ではなく全体を通した通し番号を
'   使う。これにより、あるデータが全体の何件目から何件目に
'   あたるかを、束をまたいでも一意に追跡できる。
' ・束枝番は「塊（会社×束の塊）が変わったかどうか」という、
'   塊が確定して初めて定義できる情報である。そのため作業シート
'   （1件単位）の段階では採番せず、出力シート（塊単位）が
'   完成した後にステップ3として改めて上から見て採番する。
'   判定は単純で、出力シートを上から見て、束番号が1行上と同じ
'   なら束枝番を1加算、違えば1にリセットする。
'============================================================

'読取シートの列番号
Private Enum CNoWs読取
    会社名 = 1
    件数 = 2
End Enum

'作業シートの列番号
Private Enum CNoWs作業
    通し番号 = 1
    会社名 = 2
    束番号 = 3
    束内番号 = 4
End Enum

'出力シートの列番号
Private Enum CNoWs出力
    ID = 1
    会社名 = 2
    件数 = 3
    束番号 = 4
    束枝番 = 5
    開始番号 = 6
    終了番号 = 7
End Enum

Sub 出力作成()

    '======== 定数 ========

    '読取シート
    Const str読取シート名 As String = "読取"
    Const RNo_ws読取_開始行 As Long = 2

    '作業シート
    Const str作業シート名 As String = "作業"
    Const RNo_ws作業_開始行 As Long = 2

    '出力シート
    Const str出力シート名 As String = "出力"
    Const RNo_ws出力_開始行 As Long = 2

    Const lng最大束件数 As Long = 50

    '======== シート取得 ========

    Dim ws読取 As Worksheet
    Dim ws作業 As Worksheet
    Dim ws出力 As Worksheet

    Set ws読取 = Worksheets(str読取シート名)
    Set ws作業 = Worksheets(str作業シート名)
    Set ws出力 = Worksheets(str出力シート名)

    ws作業.Rows(RNo_ws作業_開始行 & ":" & ws作業.Rows.Count).ClearContents
    ws出力.Rows(RNo_ws出力_開始行 & ":" & ws出力.Rows.Count).ClearContents

    '======== ステップ1：会社名を件数分だけ作業シートへ展開し、束番号・束内番号も同時に採番 ========
    ' 1行書き込むたびに、通し番号・束内番号を1ずつ進める。
    ' 束内番号が50を超えたら、束番号を1つ進めて束内番号を1に戻す。

    Dim RNo_ws読取_最終行 As Long
    RNo_ws読取_最終行 = ws読取.Cells(ws読取.Rows.Count, CNoWs読取.会社名).End(xlUp).Row

    Dim RNo_ws作業_書込行 As Long
    RNo_ws作業_書込行 = RNo_ws作業_開始行

    '通し番号・束番号・束内番号のカウンタを初期化する
    Dim lng_ws作業_通し番号 As Long
    lng_ws作業_通し番号 = 0

    Dim lng_ws作業_束番号 As Long
    Dim lng_ws作業_束内番号 As Long
    lng_ws作業_束番号 = 1
    lng_ws作業_束内番号 = 0

    '読取シートを1行ずつ、会社の登場順に処理する
    Dim RNo_ws読取_読取行 As Long
    For RNo_ws読取_読取行 = RNo_ws読取_開始行 To RNo_ws読取_最終行

        Dim str_ws読取_会社名 As String
        Dim lng_ws読取_件数 As Long
        str_ws読取_会社名 = ws読取.Cells(RNo_ws読取_読取行, CNoWs読取.会社名).Value
        lng_ws読取_件数 = ws読取.Cells(RNo_ws読取_読取行, CNoWs読取.件数).Value

        '1社分の件数だけ、作業シートへ1件ずつ展開する
        Dim i As Long
        For i = 1 To lng_ws読取_件数

            lng_ws作業_通し番号 = lng_ws作業_通し番号 + 1

            lng_ws作業_束内番号 = lng_ws作業_束内番号 + 1
            If lng_ws作業_束内番号 > lng最大束件数 Then
                lng_ws作業_束番号 = lng_ws作業_束番号 + 1
                lng_ws作業_束内番号 = 1
            End If

            ws作業.Cells(RNo_ws作業_書込行, CNoWs作業.通し番号).Value = lng_ws作業_通し番号
            ws作業.Cells(RNo_ws作業_書込行, CNoWs作業.会社名).Value = str_ws読取_会社名
            ws作業.Cells(RNo_ws作業_書込行, CNoWs作業.束番号).Value = lng_ws作業_束番号
            ws作業.Cells(RNo_ws作業_書込行, CNoWs作業.束内番号).Value = lng_ws作業_束内番号

            RNo_ws作業_書込行 = RNo_ws作業_書込行 + 1

        Next i

    Next RNo_ws読取_読取行

    Dim lng総件数 As Long
    lng総件数 = lng_ws作業_通し番号

    '======== ステップ2：作業シートを上から転記し、会社名か束番号が変わったら出力行を改める ========
    ' 出力1行＝「束×会社」の単位。会社の境界・束の境界のどちらでも区切る。
    ' 束枝番はこの時点ではまだ振らない（ステップ3でまとめて振る）。

    '出力行番号・出力IDのカウンタを初期化する
    Dim RNo_ws出力_書込行 As Long: RNo_ws出力_書込行 = RNo_ws出力_開始行
    Dim lng_ws出力_ID As Long: lng_ws出力_ID = 1

    '「同じ会社」かつ「同じ束番号」が連続している塊の先頭行。
    '塊の終わりは読み進めれば都度わかるが、始まりは
    '前の区切りの次まで遡らないとわからないため保持しておく。
    Dim RNo_ws作業_区間開始行 As Long: RNo_ws作業_区間開始行 = RNo_ws作業_開始行

    Dim RNo_ws作業_読取行 As Long
    For RNo_ws作業_読取行 = RNo_ws作業_開始行 To RNo_ws作業_開始行 + lng総件数 - 1

        Dim is改行予定 As Boolean
        is改行予定 = False

        '最終行に達したら、無条件で塊の区切りとする
        If RNo_ws作業_読取行 = RNo_ws作業_開始行 + lng総件数 - 1 Then is改行予定 = True
        '次の行で会社が変わるなら、そこで塊を区切る
        If ws作業.Cells(RNo_ws作業_読取行 + 1, CNoWs作業.会社名).Value <> ws作業.Cells(RNo_ws作業_区間開始行, CNoWs作業.会社名).Value Then is改行予定 = True
        '次の行で束番号が変わるなら、そこでも塊を区切る
        If ws作業.Cells(RNo_ws作業_読取行 + 1, CNoWs作業.束番号).Value <> ws作業.Cells(RNo_ws作業_区間開始行, CNoWs作業.束番号).Value Then is改行予定 = True

        If is改行予定 Then

            ws出力.Cells(RNo_ws出力_書込行, CNoWs出力.ID).Value = lng_ws出力_ID
            ws出力.Cells(RNo_ws出力_書込行, CNoWs出力.会社名).Value = ws作業.Cells(RNo_ws作業_区間開始行, CNoWs作業.会社名).Value
            ws出力.Cells(RNo_ws出力_書込行, CNoWs出力.件数).Value = RNo_ws作業_読取行 - RNo_ws作業_区間開始行 + 1
            ws出力.Cells(RNo_ws出力_書込行, CNoWs出力.束番号).Value = ws作業.Cells(RNo_ws作業_区間開始行, CNoWs作業.束番号).Value
            ws出力.Cells(RNo_ws出力_書込行, CNoWs出力.開始番号).Value = ws作業.Cells(RNo_ws作業_区間開始行, CNoWs作業.通し番号).Value
            ws出力.Cells(RNo_ws出力_書込行, CNoWs出力.終了番号).Value = ws作業.Cells(RNo_ws作業_読取行, CNoWs作業.通し番号).Value

            lng_ws出力_ID = lng_ws出力_ID + 1
            RNo_ws出力_書込行 = RNo_ws出力_書込行 + 1
            RNo_ws作業_区間開始行 = RNo_ws作業_読取行 + 1

        End If

    Next RNo_ws作業_読取行

    '======== ステップ3：出力シートを上から見て、束番号が1行上と同じなら束枝番を加算 ========
    ' 出力シートは既に「束×会社」の塊単位で1行にまとまっているため、
    ' ここでは束番号の変化を見るだけで枝番が決まる。
    ' 直前の束番号の初期値は0（実在しない束番号）にしておくことで、
    ' 1行目は必ず「変わった」と判定され、束枝番が1から始まる。

    Dim RNo_ws出力_最終行 As Long
    RNo_ws出力_最終行 = RNo_ws出力_書込行 - 1

    '束枝番・直前の束番号のカウンタを初期化する
    Dim lng_ws出力_束枝番 As Long
    lng_ws出力_束枝番 = 0

    Dim lng_ws出力_直前の束番号 As Long
    lng_ws出力_直前の束番号 = 0

    Dim RNo_ws出力_採番行 As Long
    For RNo_ws出力_採番行 = RNo_ws出力_開始行 To RNo_ws出力_最終行

        Dim lng_ws出力_現在の束番号 As Long
        lng_ws出力_現在の束番号 = ws出力.Cells(RNo_ws出力_採番行, CNoWs出力.束番号).Value

        If lng_ws出力_現在の束番号 = lng_ws出力_直前の束番号 Then
            '同じ束の中がまだ続いているので、枝番を1つ進める
            lng_ws出力_束枝番 = lng_ws出力_束枝番 + 1
        Else
            '新しい束に入ったので、枝番を1からリセットする
            lng_ws出力_束枝番 = 1
            lng_ws出力_直前の束番号 = lng_ws出力_現在の束番号
        End If

        ws出力.Cells(RNo_ws出力_採番行, CNoWs出力.束枝番).Value = lng_ws出力_束枝番

    Next RNo_ws出力_採番行

    '======== 完了 ========

    MsgBox "出力が完了しました。"

End Sub

3参考

chatGPT