Uncategorized | まなびの書 https://manabinotes.com Tue, 31 Mar 2026 14:03:41 +0000 ja hourly 1 https://wordpress.org/?v=6.9.4 Power Query台帳で最終更新日時を表示する簡単な方法 https://manabinotes.com/power-query%e5%8f%b0%e5%b8%b3%e3%81%a7%e6%9c%80%e7%b5%82%e6%9b%b4%e6%96%b0%e6%97%a5%e6%99%82%e3%82%92%e8%a1%a8%e7%a4%ba%e3%81%99%e3%82%8b%e7%b0%a1%e5%8d%98%e3%81%aa%e6%96%b9%e6%b3%95/ https://manabinotes.com/power-query%e5%8f%b0%e5%b8%b3%e3%81%a7%e6%9c%80%e7%b5%82%e6%9b%b4%e6%96%b0%e6%97%a5%e6%99%82%e3%82%92%e8%a1%a8%e7%a4%ba%e3%81%99%e3%82%8b%e7%b0%a1%e5%8d%98%e3%81%aa%e6%96%b9%e6%b3%95/#respond Tue, 31 Mar 2026 13:52:44 +0000 https://manabinotes.com/?p=334 Power Queryの台帳で最終更新日時を表示したいときは、
更新日時専用の軽いクエリを1本作る方法がおすすめです。

VBAで更新完了を監視しようとすると不安定になりやすいため、
まずはこの方法がいちばんシンプルで実用的です。

やり方

Power Queryで空クエリを作り、次のコードを入れます。

let
    Source = #table(
        {"最終更新日時"},
        {{DateTime.FixedLocalNow()}}
    )
in
    Source

このクエリをシートに読み込めば、更新時刻が1セルで表示できます。 <h3>ポイント</h3>

  • 本体クエリとは別に、更新日時専用クエリを作る
  • 「すべて更新」を押すと、本体と一緒に更新される
  • VBA不要なので固まりにくい
  • 作りが単純で保守しやすい

セル形式の補足

読み込んだセルは、Excel側で表示形式を整えるのがおすすめです。

たとえば次の表示形式にすると見やすいです。

yyyy/mm/dd hh:mm:ss

日付だけでよければこちらでもOKです。

yyyy/mm/dd

文字付きで見せたい場合は、別セルで次のように参照します。

="最終更新: "&TEXT(A2,"yyyy/mm/dd hh:mm:ss")

注意点

この方法で表示されるのは、厳密には 「更新日時クエリが更新された時刻」です。

そのため、重い本体クエリの成功・失敗まで厳密に判定したい場合は、
別の仕組みが必要になります。

まとめ

Power Query台帳で最終更新日時を表示したいなら、
更新日時専用の軽いクエリを1本作る方法が最もおすすめです。

シンプルで軽く、実務でも扱いやすい方法です。

]]> https://manabinotes.com/power-query%e5%8f%b0%e5%b8%b3%e3%81%a7%e6%9c%80%e7%b5%82%e6%9b%b4%e6%96%b0%e6%97%a5%e6%99%82%e3%82%92%e8%a1%a8%e7%a4%ba%e3%81%99%e3%82%8b%e7%b0%a1%e5%8d%98%e3%81%aa%e6%96%b9%e6%b3%95/feed/ 0 【PAD】エクセルデータから複数リストを生成 https://manabinotes.com/%e3%80%90pad%e3%80%91%e3%82%a8%e3%82%af%e3%82%bb%e3%83%ab%e3%83%87%e3%83%bc%e3%82%bf%e3%81%8b%e3%82%89%e8%a4%87%e6%95%b0%e3%83%aa%e3%82%b9%e3%83%88%e3%82%92%e7%94%9f%e6%88%90/ https://manabinotes.com/%e3%80%90pad%e3%80%91%e3%82%a8%e3%82%af%e3%82%bb%e3%83%ab%e3%83%87%e3%83%bc%e3%82%bf%e3%81%8b%e3%82%89%e8%a4%87%e6%95%b0%e3%83%aa%e3%82%b9%e3%83%88%e3%82%92%e7%94%9f%e6%88%90/#respond Thu, 05 Mar 2026 23:15:09 +0000 https://manabinotes.com/?p=297 
SET ImportPath TO $'''C:\\SAP_DL\\MfgList.xlsx'''
SET SheetName TO $'''台帳'''
SET DataRange_FirstRow TO 8
SET DataRange_FirstColumn TO 1
SET KeyColumn TO 2
SET DownloadPath TO $'''C:\\SAP_DL\\'''
**REGION エクセルデータの読込
BLOCK Excelプロセス残留防止
ON BLOCK ERROR

END
    Excel.LaunchExcel.LaunchAndOpenUnderExistingProcess Path: ImportPath Visible: True ReadOnly: True UseMachineLocale: False Instance=> ExcelInstance
    Excel.SetActiveWorksheet.ActivateWorksheetByName Instance: ExcelInstance Name: SheetName
    Excel.ReadFromExcel.ReadAllCells Instance: ExcelInstance GetCellContentsMode: Excel.GetCellContentsMode.TypedValues FirstLineIsHeader: False RangeValue=> ExcelDataAll
    Excel.ReadFromExcel.ReadCells Instance: ExcelInstance StartColumn: DataRange_FirstColumn StartRow: DataRange_FirstRow EndColumn: ExcelDataAll.Columns.Count EndRow: ExcelDataAll.RowsCount GetCellContentsMode: Excel.GetCellContentsMode.TypedValues FirstLineIsHeader: False RangeValue=> ExcelDataExtracted
    Excel.CloseExcel.Close Instance: ExcelInstance
END
Excel.CloseExcel.Close Instance: ExcelInstance
ON ERROR

END
**ENDREGION
**REGION データの整理
Variables.FilterDataTable DataTable: ExcelDataExtracted FilterParameters: { ^['RULE', 'COLUMN', 'OPERATOR', 'VALUE'], [$'''''', 2, $'''Contains''', $'''U'''], [$'''Or''', 2, $'''Contains''', $'''O'''] } MatchCase: True FilteredDataTable=> FilteredTable_ST
Variables.FilterDataTable DataTable: ExcelDataExtracted FilterParameters: { ^['RULE', 'COLUMN', 'OPERATOR', 'VALUE'], [$'''''', 2, $'''Contains''', $'''V'''] } MatchCase: True FilteredDataTable=> FilteredTable_OD
Variables.RetrieveDataTableColumnIntoList DataTable: FilteredTable_ST ColumnNameOrIndex: KeyColumn - 1 ColumnAsList=> List_ST
Variables.RetrieveDataTableColumnIntoList DataTable: FilteredTable_OD ColumnNameOrIndex: KeyColumn - 1 ColumnAsList=> List_OD
**ENDREGION
**REGION 実際の処理
# ここでList_STを使った処理
Clipboard.SetText Text: List_ST
Clipboard.GetText Text=> ClipboardText_ST
# ここでList_STを使った処理
Clipboard.SetText Text: List_OD
Clipboard.GetText Text=> ClipboardText_OD
**ENDREGION
]]> https://manabinotes.com/%e3%80%90pad%e3%80%91%e3%82%a8%e3%82%af%e3%82%bb%e3%83%ab%e3%83%87%e3%83%bc%e3%82%bf%e3%81%8b%e3%82%89%e8%a4%87%e6%95%b0%e3%83%aa%e3%82%b9%e3%83%88%e3%82%92%e7%94%9f%e6%88%90/feed/ 0 【VBA】複数ファイルの収集 https://manabinotes.com/%e3%80%90vba%e3%80%91%e8%a4%87%e6%95%b0%e3%83%95%e3%82%a1%e3%82%a4%e3%83%ab%e3%81%ae%e5%8f%8e%e9%9b%86/ https://manabinotes.com/%e3%80%90vba%e3%80%91%e8%a4%87%e6%95%b0%e3%83%95%e3%82%a1%e3%82%a4%e3%83%ab%e3%81%ae%e5%8f%8e%e9%9b%86/#respond Sun, 01 Mar 2026 16:18:20 +0000 https://manabinotes.com/?p=265
  1. 処理の流れ
  2. Dictionaryの検索

処理の流れ

マクロ FileCopyMain を実行すると、以下の順番で動きます。

1. 入力チェック シートのB3（コピー元）とB4（コピー先）を読み取り、空欄がないか、コピー先が C:\ や D:\ などローカルドライブかを確認します。\\server\... のようなネットワークパスが指定されていたらブロックします。

2. フォルダ存在チェック コピー元フォルダが実際に存在するか確認します。コピー先フォルダが存在しない場合は「作成しますか？」と聞いてきます。

3. コピー元のファイル一覧をキャッシュ コピー元フォルダの中身を一度だけ全部読み込んで、メモリ上のリスト（Dictionary）に保存します。これが「キャッシュ」です（詳しくは後述）。

4. 実行確認ダイアログ コピー元、コピー先、対象ファイル数をまとめたメッセージボックスが出ます。「はい」を押さない限りコピーは始まりません。

5. 上書き確認 コピー先に同名ファイルがある場合、その一覧を表示して「上書きしてよろしいですか？」と確認します。

6. コピー実行 ファイルを1つずつコピーしながら、ステータスバーに進捗（「3/20 コピー中…」のように）を表示します。各ファイルの結果はC列に緑（成功）または赤（失敗・見つからない）で書き込まれます。

7. 完了報告 成功数・失敗数をまとめたメッセージが表示されます。

Dictionaryの検索

Dir()でフォルダ内のファイル名を1つずつ取得してDictionaryに入れていく処理ですが、これはファイル名の文字列を読み取るだけで、ファイルの中身を開いたりしません。100個程度のファイル名取得はネットワーク越しでも1回の通信で済むことがほとんどなので、体感としてはエクスプローラでそのフォルダを開くのと同じくらいの待ち時間です。

キャッシュ後の検索は、Dictionaryがハッシュテーブルという仕組みで動いているため、100個だろうが1000個だろうが1回の検索はほぼ一瞬です。20ファイル分の検索を合わせてもミリ秒レベルで終わります。

ファイルコピーツールダウンロード
VBAコードダウンロード
'=============================================================
' ファイルコピーツール VBAマクロ
' 使い方: Alt+F11 → 挿入 → 標準モジュール → このコードを貼り付け
'=============================================================

Option Explicit

' --- 定数 ---
Private Const SHEET_NAME As String = "ファイルコピー"
Private Const ROW_SRC As Long = 3       ' コピー元パス行
Private Const ROW_DST As Long = 4       ' コピー先パス行
Private Const COL_PATH As Long = 2      ' パス列 (B列)
Private Const ROW_FILE_START As Long = 8 ' ファイル名開始行
Private Const COL_NO As Long = 1        ' No.列 (A列)
Private Const COL_FILE As Long = 2      ' ファイル名列 (B列)
Private Const COL_RESULT As Long = 3    ' 結果列 (C列)

'=============================================================
' メインルーチン
'=============================================================
Public Sub FileCopyMain()

    Dim ws As Worksheet
    Dim srcFolder As String
    Dim dstFolder As String
    Dim fileNames() As String
    Dim fileCount As Long
    Dim i As Long

    On Error GoTo ErrHandler

    ' シート取得
    Set ws = ThisWorkbook.Worksheets(SHEET_NAME)

    ' パス取得・整形
    srcFolder = Trim(CStr(ws.Cells(ROW_SRC, COL_PATH).Value))
    dstFolder = Trim(CStr(ws.Cells(ROW_DST, COL_PATH).Value))

    ' 末尾に \ を付与
    If Right(srcFolder, 1) <> "\" Then srcFolder = srcFolder & "\"
    If Right(dstFolder, 1) <> "\" Then dstFolder = dstFolder & "\"

    ' --- バリデーション ---

    ' 空チェック
    If srcFolder = "\" Or dstFolder = "\" Then
        MsgBox "コピー元フォルダとコピー先フォルダを入力してください。", vbExclamation, "入力エラー"
        Exit Sub
    End If

    ' コピー先がローカルドライブかチェック
    If Not IsLocalPath(dstFolder) Then
        MsgBox "コピー先はローカルドライブ（C:\, D:\ 等）を指定してください。" & vbCrLf & _
               "ネットワークパス（\\で始まるパス）は指定できません。" & vbCrLf & vbCrLf & _
               "現在の指定: " & dstFolder, vbExclamation, "コピー先エラー"
        Exit Sub
    End If

    ' コピー元フォルダ存在チェック
    If Dir(srcFolder, vbDirectory) = "" Then
        MsgBox "コピー元フォルダが見つかりません:" & vbCrLf & srcFolder, vbExclamation, "パスエラー"
        Exit Sub
    End If

    ' コピー先フォルダ存在チェック
    If Dir(dstFolder, vbDirectory) = "" Then
        Dim ans As VbMsgBoxResult
        ans = MsgBox("コピー先フォルダが存在しません。作成しますか？" & vbCrLf & dstFolder, _
                     vbYesNo + vbQuestion, "フォルダ作成")
        If ans = vbYes Then
            MkDirRecursive dstFolder
        Else
            Exit Sub
        End If
    End If

    ' ファイル名一覧を取得
    fileCount = GetFileList(ws, fileNames)

    If fileCount = 0 Then
        MsgBox "コピー対象ファイルが1つも入力されていません。", vbExclamation, "入力エラー"
        Exit Sub
    End If

    ' 結果列クリア
    ClearResults ws

    ' --- 実行前確認 ---
    Dim confirmMsg As String
    confirmMsg = "以下の内容でファイルコピーを実行します。" & vbCrLf & vbCrLf
    confirmMsg = confirmMsg & "【コピー元】" & vbCrLf & srcFolder & vbCrLf & vbCrLf
    confirmMsg = confirmMsg & "【コピー先】" & vbCrLf & dstFolder & vbCrLf & vbCrLf
    confirmMsg = confirmMsg & "【対象ファイル数】" & fileCount & " 件" & vbCrLf & vbCrLf
    confirmMsg = confirmMsg & "実行してよろしいですか？"

    If MsgBox(confirmMsg, vbYesNo + vbQuestion, "実行確認") <> vbYes Then
        Exit Sub
    End If

    ' --- コピー元ファイル一覧をキャッシュ（ネットワーク負荷軽減） ---
    ' ネットワークドライブは Dir() が遅いため、1回だけ列挙してDictionaryに格納
    Application.StatusBar = "コピー元フォルダを読み込み中（ネットワークドライブの場合、時間がかかります）..."
    DoEvents

    Dim srcFileDict As Object
    Set srcFileDict = CreateObject("Scripting.Dictionary")
    srcFileDict.CompareMode = vbTextCompare  ' 大文字小文字を無視

    Dim dirFile As String
    dirFile = Dir(srcFolder & "*.*")
    Do While dirFile <> ""
        If Not srcFileDict.Exists(LCase(dirFile)) Then
            srcFileDict.Add LCase(dirFile), dirFile  ' Key=小文字, Value=実際の名前
        End If
        dirFile = Dir()
    Loop
    Application.StatusBar = False

    ' --- 既存ファイル上書き確認 ---
    Dim overwriteList As String
    Dim overwriteCount As Long
    overwriteCount = 0
    overwriteList = ""

    For i = 0 To fileCount - 1
        Dim actualName As String
        actualName = FindInCache(srcFileDict, fileNames(i))
        If actualName <> "" Then
            If Dir(dstFolder & actualName) <> "" Then
                overwriteCount = overwriteCount + 1
                overwriteList = overwriteList & "  " & actualName & vbCrLf
            End If
        End If
    Next i

    If overwriteCount > 0 Then
        Dim owMsg As String
        owMsg = "コピー先に以下の " & overwriteCount & " ファイルが既に存在します。" & vbCrLf
        owMsg = owMsg & "上書きしてよろしいですか？" & vbCrLf & vbCrLf
        owMsg = owMsg & overwriteList

        If MsgBox(owMsg, vbYesNo + vbExclamation, "上書き確認") <> vbYes Then
            Exit Sub
        End If
    End If

    ' --- コピー実行 ---
    Application.StatusBar = "ファイルコピー処理中..."
    Application.ScreenUpdating = False

    Dim successCount As Long, failCount As Long, skipCount As Long
    successCount = 0: failCount = 0: skipCount = 0

    For i = 0 To fileCount - 1
        Dim rowNum As Long
        rowNum = ROW_FILE_START + i

        DoEvents  ' UIの応答を維持
        Application.StatusBar = "コピー中... (" & (i + 1) & "/" & fileCount & ") " & fileNames(i)

        ' キャッシュから大文字小文字を無視して検索
        actualName = FindInCache(srcFileDict, fileNames(i))

        If actualName = "" Then
            ' ファイルが見つからない
            SetResult ws, rowNum, "見つかりません", RGB(200, 0, 0)
            failCount = failCount + 1
        Else
            ' コピー実行
            On Error Resume Next
            FileCopy srcFolder & actualName, dstFolder & actualName

            If Err.Number = 0 Then
                SetResult ws, rowNum, "コピー完了", RGB(0, 128, 0)
                successCount = successCount + 1
            Else
                SetResult ws, rowNum, "エラー: " & Err.Description, RGB(200, 0, 0)
                failCount = failCount + 1
                Err.Clear
            End If
            On Error GoTo ErrHandler
        End If
    Next i

    Application.ScreenUpdating = True
    Application.StatusBar = False

    ' --- 完了メッセージ ---
    Dim resultMsg As String
    resultMsg = "ファイルコピーが完了しました。" & vbCrLf & vbCrLf
    resultMsg = resultMsg & "  成功: " & successCount & " 件" & vbCrLf
    resultMsg = resultMsg & "  失敗: " & failCount & " 件" & vbCrLf
    resultMsg = resultMsg & "  合計: " & fileCount & " 件"

    If failCount > 0 Then
        MsgBox resultMsg, vbExclamation, "完了（一部エラーあり）"
    Else
        MsgBox resultMsg, vbInformation, "完了"
    End If

    Exit Sub

ErrHandler:
    Application.ScreenUpdating = True
    Application.StatusBar = False
    MsgBox "予期しないエラーが発生しました。" & vbCrLf & vbCrLf & _
           "エラー番号: " & Err.Number & vbCrLf & _
           "内容: " & Err.Description, vbCritical, "エラー"
End Sub

'=============================================================
' ローカルパス判定（ドライブレターで始まるか）
'=============================================================
Private Function IsLocalPath(ByVal path As String) As Boolean
    IsLocalPath = False
    If Len(path) >= 2 Then
        Dim firstChar As String
        firstChar = UCase(Left(path, 1))
        If firstChar >= "A" And firstChar <= "Z" Then
            If Mid(path, 2, 1) = ":" Then
                ' ネットワークドライブのマッピングも除外したい場合は
                ' 以下のチェックを有効にしてください
                ' （ただし、マッピングされたドライブはローカル扱いにする場合はコメントアウト）
                '
                ' Dim drv As String
                ' drv = Left(path, 2)
                ' Dim fso As Object
                ' Set fso = CreateObject("Scripting.FileSystemObject")
                ' If fso.DriveExists(drv) Then
                '     If fso.GetDrive(drv).DriveType = 3 Then ' Network
                '         IsLocalPath = False
                '         Exit Function
                '     End If
                ' End If

                IsLocalPath = True
            End If
        End If
    End If
End Function

'=============================================================
' キャッシュ済みDictionaryからファイルを検索（大文字小文字無視）
' ネットワークドライブへのDir()は1回だけに抑えるための仕組み
'=============================================================
Private Function FindInCache(ByVal dict As Object, ByVal targetName As String) As String
    Dim key As String
    key = LCase(Trim(targetName))
    If dict.Exists(key) Then
        FindInCache = dict(key)  ' 実際のファイル名を返す
    Else
        FindInCache = ""
    End If
End Function

'=============================================================
' ファイル名一覧を取得
'=============================================================
Private Function GetFileList(ByVal ws As Worksheet, ByRef fileNames() As String) As Long
    Dim count As Long
    count = 0
    Dim row As Long
    row = ROW_FILE_START

    ' まず件数をカウント
    Do While row <= 1000  ' 安全上限
        Dim val As Variant
        val = ws.Cells(row, COL_FILE).Value
        If IsEmpty(val) Or Trim(CStr(val)) = "" Then
            Exit Do
        End If
        count = count + 1
        row = row + 1
    Loop

    If count = 0 Then
        GetFileList = 0
        Exit Function
    End If

    ReDim fileNames(0 To count - 1)

    Dim i As Long
    For i = 0 To count - 1
        fileNames(i) = Trim(CStr(ws.Cells(ROW_FILE_START + i, COL_FILE).Value))
    Next i

    GetFileList = count
End Function

'=============================================================
' 結果列をクリア
'=============================================================
Private Sub ClearResults(ByVal ws As Worksheet)
    Dim row As Long
    row = ROW_FILE_START
    Do While row <= 1000
        If IsEmpty(ws.Cells(row, COL_FILE).Value) Or Trim(CStr(ws.Cells(row, COL_FILE).Value)) = "" Then
            Exit Do
        End If
        ws.Cells(row, COL_RESULT).Value = ""
        ws.Cells(row, COL_RESULT).Font.Color = RGB(0, 0, 0)
        row = row + 1
    Loop
End Sub

'=============================================================
' 結果セルに値と色を設定
'=============================================================
Private Sub SetResult(ByVal ws As Worksheet, ByVal row As Long, ByVal text As String, ByVal clr As Long)
    ws.Cells(row, COL_RESULT).Value = text
    ws.Cells(row, COL_RESULT).Font.Color = clr
End Sub

'=============================================================
' フォルダを再帰的に作成
'=============================================================
Private Sub MkDirRecursive(ByVal path As String)
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    If Not fso.FolderExists(path) Then
        ' 親フォルダを先に作成
        Dim parentPath As String
        parentPath = fso.GetParentFolderName(path)
        If Not fso.FolderExists(parentPath) Then
            MkDirRecursive parentPath
        End If
        fso.CreateFolder path
    End If
End Sub
]]> https://manabinotes.com/%e3%80%90vba%e3%80%91%e8%a4%87%e6%95%b0%e3%83%95%e3%82%a1%e3%82%a4%e3%83%ab%e3%81%ae%e5%8f%8e%e9%9b%86/feed/ 0 【VBA】微妙に違うファイルの比較&集約 https://manabinotes.com/%e3%80%90vba%e3%80%91%e5%be%ae%e5%a6%99%e3%81%ab%e9%81%95%e3%81%86%e3%83%95%e3%82%a1%e3%82%a4%e3%83%ab%e3%81%ae%e6%af%94%e8%bc%83%e9%9b%86%e7%b4%84/ https://manabinotes.com/%e3%80%90vba%e3%80%91%e5%be%ae%e5%a6%99%e3%81%ab%e9%81%95%e3%81%86%e3%83%95%e3%82%a1%e3%82%a4%e3%83%ab%e3%81%ae%e6%af%94%e8%bc%83%e9%9b%86%e7%b4%84/#respond Wed, 25 Feb 2026 03:05:52 +0000 https://manabinotes.com/?p=253
  1. やりたかったこと
  2. 設計方針：「定数で全部変えられる」
  3. パフォーマンス：4つの高速化ポイント
    1. 1. 配列一括 Read/Write
    2. 2. Scripting.Dictionary で O(1) ルックアップ
    3. 3. シェルソート
    4. 4. ローカルTEMPコピー
  4. はまったポイント
    1. .bas ファイルの文字化け
    2. OneDrive パスの罠
  5. コード構成（最終版）
  6. まとめ

やりたかったこと

複数のExcelファイル（dwglist_n1～n8）に散らばった部品リストを、1つのブックに集約したい。

  • output1: クロスリファレンス表（どのファイルにどの部品があるか〇で表示）
  • output2: キーごとのメモ集約表（コメントを結合し、一部のファイルにしか無い場合は「n1,n3のみ」と注記）

対象規模は 300行 × 8ファイル。共有ドライブ上のファイルを扱う。

設計方針：「定数で全部変えられる」

列番号・行範囲・ソートキー・フィルタ条件をすべてコード冒頭の Const で定義した。実務でレイアウト変更があっても、定数を書き換えるだけで対応できる。

vb

' 読み込み元
Const SRC_COL_KEY   As Long = 11  ' K列: 集約キー
Const SRC_COL_CMNT  As Long = 27  ' AA列: コメント
Const SRC_LAST_COL  As Long = 92  ' CN列: 最終列

' ソートキー（5段階）
Const SORT_KEY_1 As Long = 11   ' K列
Const SORT_KEY_2 As Long = 15   ' O列
Const SORT_KEY_3 As Long = 14   ' N列

' output2 範囲フィルタ
Const OUT2_KEY_FROM As String = ""  ' 空なら制限なし
Const OUT2_KEY_TO   As String = ""

' output2 列ソース
Const OUT2_COL_NO   As Long = 20  ' T列 → no
Const OUT2_COL_NAME As Long = 26  ' Z列 → name

パフォーマンス：4つの高速化ポイント

1. 配列一括 Read/Write

セルを1つずつ読み書きすると、COM呼び出しが毎回発生して遅い。Range.Value で配列に一括読み込み→処理→一括書き込みにすることで、数十倍速くなる。

vb

data = .Range(.Cells(5, 1), .Cells(lastRow, 92)).Value  ' 一括読み込み
ws1.Range(...).Value = out1                                ' 一括書き込み

2. Scripting.Dictionary で O(1) ルックアップ

キーの重複チェック・クロスリファレンスの存在判定に Scripting.Dictionary を使用。配列の線形検索 O(n) に比べて、ハッシュベースの O(1) で高速。

3. シェルソート

バブルソート O(n^2) → シェルソート O(n^1.3) に変更。300行程度なら体感差は小さいが、データ増加時に効いてくる。5段階の多段キー比較に対応。

4. ローカルTEMPコピー

共有ドライブ上のファイルを直接 Workbooks.Open すると、Excelがネットワーク越しに逐次アクセスするため遅い。fso.CopyFile でローカルの %TEMP% に一括コピーしてから開くことで、ネットワーク転送を1回に削減。

vb

fso.CopyFile srcFiles(i), tempPath, True  ' 一括コピー
Set srcWb = Workbooks.Open(tempPath, ...)  ' ローカルから読む
' ... 処理後 ...
fso.DeleteFile tempPath, True              ' 後片付け

はまったポイント

.bas ファイルの文字化け

VBEは Shift-JIS (CP932) でしか .bas を読めないが、エディタやリンターが勝手にUTF-8に変換してしまい、日本語コメントが文字化けした。

解決策: Pythonで Shift-JIS + CRLF の .bas を生成し、ZIP に格納して渡す。ZIPの中身はリンターが触れないので安全。

OneDrive パスの罠

ThisWorkbook.Path が https://d.docs.live.net/... のようなURL形式を返すことがある。ローカルパスへの自動変換は環境依存で不安定。

解決策: settingシートの C1 にベースフォルダパスを直接指定する方式に変更。自動解決を諦めて、確実な手動指定にした。

コード構成（最終版）

Sub RunAggregate()
  ├─ 1. settingシート読み込み（フォルダパス・ファイルリスト）
  ├─ 2. ファイルリスト取得＋存在チェック
  ├─ 3. 全ソースファイル読み込み → Dictionary格納
  │     ├─ ローカルTEMPコピー
  │     ├─ 配列一括読み込み
  │     ├─ rowDict（全列データ保持）
  │     └─ sortDict（ソートキー値保持）
  ├─ 4. シェルソート（多段キー）
  ├─ 5. output1 出力（全列＋〇マーク上書き）
  └─ 6. output2 出力（no + name + 備考、範囲フィルタ付き）

まとめ

  • 定数化: レイアウト変更に強い。列番号・ソート順・フィルタ範囲がすべてコード冒頭で完結
  • 配列一括処理 + Dictionary: VBAでも十分高速に処理できる
  • 共有ドライブ対策: TEMPコピーで読み込み速度を改善
  • エンコーディング対策: ZIP格納で文字化けを回避
  • OneDrive対策: 自動解決より手動指定が確実
Option Explicit

' ============================================================
'  処理A : 部品リスト集約マクロ
'  ────────────────────────────────────────────────────────────
'  ・settingシートで指定したソースファイル(import/)を読み込み、
'    output1 に〇クロスリファレンス表（ソース全列）、
'    output2 にキーごとのメモ集約表を出力する。
'  ・配列一括 Read/Write ＋ シェルソートで高速処理
' ============================================================


Sub RunAggregate()

    ' ==========================================================
    '  定数定義：読み込み元（ソースファイル）の列番号
    '  ソースの列範囲は A(1)～CN(92)
    ' ==========================================================
    Const SRC_COL_KEY   As Long = 11  ' K列  : キー（集約キー）
    Const SRC_COL_CMNT  As Long = 27  ' AA列 : コメント
    Const SRC_LAST_COL  As Long = 92  ' CN列 : データ最終列
    Const SRC_START_ROW As Long = 5   ' データ開始行（4行目はヘッダ）

    ' ==========================================================
    '  定数定義：出力先（output1）の列番号・行番号
    ' ==========================================================
    Const OUT_COL_KEY   As Long = 11  ' K列  : キー表示位置
    Const OUT_COL_WORK  As Long = 27  ' AA列 : 作業（コメント）
    Const OUT_COL_N     As Long = 2   ' B列  : n列の開始位置
    Const OUT_HDR_ROW   As Long = 4   ' ヘッダ行（B4～I4 に n1,n2,...）

    ' ==========================================================
    '  定数定義：出力先（output2）の列番号
    '  1列目=no(T列), 2列目=name(Z列), 3列目=備考
    ' ==========================================================
    Const OUT2_COL_NO   As Long = 20  ' T列  : no（ソースのT列から取得）
    Const OUT2_COL_NAME As Long = 26  ' Z列  : name（ソースのZ列から取得）

    ' ==========================================================
    '  定数定義：settingシートの巡回範囲
    ' ==========================================================
    Const START_ROW As Long = 2   ' ファイルリスト開始行
    Const END_ROW   As Long = 10  ' ファイルリスト終了行

    ' ==========================================================
    '  定数定義：ファイル名トリム（output2 専用）
    '  output2 出力時のみ、キー値の先頭・末尾を除去する。
    '  output1 には影響しない。
    '  不要なら "" にすればスキップされる。
    ' ==========================================================
    Const FNAME_TRIM_PREFIX As String = ""   ' 先頭から除去する文字列
    Const FNAME_TRIM_SUFFIX As String = ""   ' 末尾から除去する文字列

    ' ==========================================================
    '  定数定義：output2 キー範囲フィルタ
    '  output2 に出力するキーの範囲を指定する。
    '  文字列比較（昇順）で FROM ≦ キー ≦ TO の行のみ出力。
    '  空文字 "" なら制限なし（全キー出力）。
    '  例: "A00-0000" ～ "B99-9999" → A～B で始まるキーのみ
    ' ==========================================================
    Const OUT2_KEY_FROM As String = ""   ' 開始キー（空なら制限なし）
    Const OUT2_KEY_TO   As String = ""   ' 終了キー（空なら制限なし）

    ' ==========================================================
    '  定数定義：ソートキー（最大5段階）
    '  出力の並び順を制御する。列番号を指定（0 = 使わない）。
    '  例: K列(11)→O列(15)→N列(14) の順でソート
    ' ==========================================================
    Const SORT_KEY_1 As Long = 11   ' 第1キー: K列
    Const SORT_KEY_2 As Long = 15   ' 第2キー: O列
    Const SORT_KEY_3 As Long = 14   ' 第3キー: N列
    Const SORT_KEY_4 As Long = 0    ' 第4キー: なし
    Const SORT_KEY_5 As Long = 0    ' 第5キー: なし

    ' ==========================================================
    '  定数定義：区切り文字・日本語ラベル
    ' ==========================================================
    Const SEP As String = "|"

    Const MARU      As String = "〇"
    Const NOMI      As String = "のみ"
    Const HDR_KEY   As String = "キー"
    Const HDR_WORK  As String = "作業"
    Const HDR_NO    As String = "no"
    Const HDR_NAME  As String = "name"
    Const HDR_MEMO  As String = "備考"

    ' ==========================================================
    '  変数宣言
    ' ==========================================================
    Dim fso        As Object
    Dim folderPath As String
    Dim srcFiles() As String
    Dim srcNames() As String
    Dim nFiles     As Long
    Dim i          As Long
    Dim r          As Long
    Dim c          As Long

    ' ----------------------------------------------------------
    '  画面更新・再計算・イベントを一時停止（高速化）
    ' ----------------------------------------------------------
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    On Error GoTo ErrHandler

    Set fso = CreateObject("Scripting.FileSystemObject")


    ' ==========================================================
    '  1. settingシート読み込み（必須）
    ' ==========================================================
    Dim wsSetting As Worksheet

    On Error Resume Next
    Set wsSetting = ThisWorkbook.Sheets("setting")
    On Error GoTo ErrHandler

    ' --- settingシートが無ければエラー終了 ---
    If wsSetting Is Nothing Then
        MsgBox "エラー: 'setting' シートが見つかりません。" & vbCrLf & _
               "settingシートを作成してください。", vbCritical
        GoTo Cleanup
    End If

    ' --- C1 からベースフォルダパスを取得 ---
    Dim baseFolder As String
    baseFolder = Trim(CStr(wsSetting.Cells(1, 3).Value & ""))

    If baseFolder <> "" Then
        If Right(baseFolder, 1) <> "\" Then baseFolder = baseFolder & "\"
        If Not fso.FolderExists(baseFolder) Then
            MsgBox "エラー: ベースフォルダが見つかりません:" & vbCrLf & _
                   baseFolder & vbCrLf & vbCrLf & _
                   "settingシートのC1を確認してください。", vbCritical
            GoTo Cleanup
        End If
        folderPath = baseFolder
    Else
        MsgBox "エラー: フォルダパスが取得できません。" & vbCrLf & _
               "settingシートのC1にベースフォルダパスを設定してください。", vbCritical
        GoTo Cleanup
    End If


    ' ==========================================================
    '  2. settingシートからファイルリストを取得
    '     （C列 START_ROW～END_ROW を巡回）
    ' ==========================================================
    If wsSetting.Cells(START_ROW, 3).Value = "" Then
        MsgBox "エラー: ファイルが設定されていません。" & vbCrLf & _
               "settingシートのC" & START_ROW & "以降にファイル名を入力してください。", vbCritical
        GoTo Cleanup
    End If

    ' --- 配列を事前確保（最大ファイル数 = END_ROW - START_ROW + 1） ---
    Dim maxFiles As Long
    maxFiles = END_ROW - START_ROW + 1
    ReDim srcFiles(1 To maxFiles)
    ReDim srcNames(1 To maxFiles)

    nFiles = 0
    Dim si As Long, sj As Long, st As String
    Dim cellVal     As String
    Dim fullPath    As String
    Dim missingFiles As String
    missingFiles = ""

    For r = START_ROW To END_ROW
        cellVal = Trim(CStr(wsSetting.Cells(r, 3).Value & ""))

        If cellVal <> "" Then
            If InStr(cellVal, "\") > 0 Or InStr(cellVal, "/") > 0 Then
                fullPath = cellVal
            Else
                fullPath = folderPath & cellVal
            End If

            If Not fso.FileExists(fullPath) Then
                missingFiles = missingFiles & "  行 " & r & ": " & cellVal & vbCrLf
            Else
                nFiles = nFiles + 1
                srcFiles(nFiles) = fullPath

                Dim dispName As String
                dispName = Trim(CStr(wsSetting.Cells(r, 2).Value & ""))
                If dispName = "" Then
                    Dim bName As String
                    bName = fso.GetFileName(fullPath)
                    If InStr(bName, "_n") > 0 Then
                        Dim nm As String
                        nm = Mid(bName, InStr(bName, "_n") + 2)
                        dispName = "n" & Left(nm, Len(nm) - 5)
                    Else
                        dispName = Left(bName, Len(bName) - 5)
                    End If
                End If
                srcNames(nFiles) = dispName
            End If
        End If
    Next r

    If missingFiles <> "" Then
        MsgBox "エラー: 以下のファイルが見つかりません:" & vbCrLf & vbCrLf & _
               missingFiles & vbCrLf & _
               "ベースフォルダ: " & folderPath, vbCritical
        GoTo Cleanup
    End If

    If nFiles = 0 Then
        MsgBox "エラー: 有効なファイルがありません。", vbCritical
        GoTo Cleanup
    End If


    ' ==========================================================
    '  3. 全ソースファイル読み込み → Dictionaryに格納
    '     key = "K列値|コメント"
    '     value = Dictionary (ソース名 → True)
    '     ※ K列に値がある行を全て対象とする（〇フィルタなし）
    ' ==========================================================
    Dim crossRef As Object           ' 全キーのクロスリファレンス
    Set crossRef = CreateObject("Scripting.Dictionary")

    ' --- ソート用：各compKeyのソートキー値を保持 ---
    Dim sortDict As Object
    Set sortDict = CreateObject("Scripting.Dictionary")

    ' --- output1用：各compKeyの全列データを保持（初回出現時） ---
    Dim rowDict As Object
    Set rowDict = CreateObject("Scripting.Dictionary")

    ' --- output1用：ソースのヘッダ行（最初のファイルから取得） ---
    Dim hdrRow As Variant
    hdrRow = Empty

    ' --- キーリスト：事前確保して後で切り詰め ---
    Const INIT_KEYS As Long = 1024
    Dim keyList() As String
    Dim keyCount As Long
    ReDim keyList(1 To INIT_KEYS)
    keyCount = 0

    Dim srcWb   As Workbook
    Dim data    As Variant
    Dim lastRow As Long
    Dim keyVal  As String
    Dim cmnt    As String
    Dim compKey As String

    ' --- 共有ドライブ高速化：ローカルTEMPにコピーしてから読む ---
    Dim tempDir  As String
    Dim tempPath As String
    tempDir = Environ("TEMP")
    If Right(tempDir, 1) <> "\" Then tempDir = tempDir & "\"

    For i = 1 To nFiles

        ' ★ ネットワークファイルをローカルにコピー（一括転送で高速）
        tempPath = tempDir & fso.GetFileName(srcFiles(i))
        On Error Resume Next
        fso.CopyFile srcFiles(i), tempPath, True
        On Error GoTo ErrHandler

        ' ローカルコピーがあればそちらを開く、なければ元パスを開く
        Dim openPath As String
        If fso.FileExists(tempPath) Then
            openPath = tempPath
        Else
            openPath = srcFiles(i)
        End If

        Set srcWb = Workbooks.Open(openPath, ReadOnly:=True, UpdateLinks:=0)

        With srcWb.Sheets(1)
            lastRow = .Cells(.Rows.Count, SRC_COL_KEY).End(xlUp).Row

            If lastRow >= SRC_START_ROW Then

                ' --- ヘッダ行を最初のファイルから取得（1行前 = 4行目） ---
                If IsEmpty(hdrRow) Then
                    hdrRow = .Range(.Cells(SRC_START_ROW - 1, 1), _
                                    .Cells(SRC_START_ROW - 1, SRC_LAST_COL)).Value
                End If

                ' --- A列～CN列 を配列に一括読み込み ---
                data = .Range(.Cells(SRC_START_ROW, 1), .Cells(lastRow, SRC_LAST_COL)).Value

                For r = 1 To UBound(data, 1)

                    keyVal = Trim(CStr(data(r, SRC_COL_KEY) & ""))

                    If keyVal <> "" Then

                        If IsEmpty(data(r, SRC_COL_CMNT)) Or _
                           CStr(data(r, SRC_COL_CMNT) & "") = "" Then
                            cmnt = ""
                        Else
                            cmnt = CStr(data(r, SRC_COL_CMNT))
                        End If

                        compKey = keyVal & SEP & cmnt

                        If Not crossRef.Exists(compKey) Then
                            Set crossRef(compKey) = CreateObject("Scripting.Dictionary")
                            keyCount = keyCount + 1

                            ' 配列が足りなければ倍に拡張
                            If keyCount > UBound(keyList) Then
                                ReDim Preserve keyList(1 To UBound(keyList) * 2)
                            End If
                            keyList(keyCount) = compKey

                            ' ★ 全列データを保持（初回出現時の値を使用）
                            Dim rv As Variant
                            ReDim rv(1 To SRC_LAST_COL)
                            For c = 1 To SRC_LAST_COL
                                rv(c) = data(r, c)
                            Next c
                            rowDict(compKey) = rv

                            ' ★ ソート用の値を保持
                            Dim sv As Variant
                            sv = Array("", "", "", "", "")
                            If SORT_KEY_1 > 0 Then sv(0) = CStr(data(r, SORT_KEY_1) & "")
                            If SORT_KEY_2 > 0 Then sv(1) = CStr(data(r, SORT_KEY_2) & "")
                            If SORT_KEY_3 > 0 Then sv(2) = CStr(data(r, SORT_KEY_3) & "")
                            If SORT_KEY_4 > 0 Then sv(3) = CStr(data(r, SORT_KEY_4) & "")
                            If SORT_KEY_5 > 0 Then sv(4) = CStr(data(r, SORT_KEY_5) & "")
                            sortDict(compKey) = sv
                        End If

                        crossRef(compKey)(srcNames(i)) = True
                    End If
                Next r
            End If
        End With

        srcWb.Close False

        ' ★ TEMPのコピーを削除（後片付け）
        On Error Resume Next
        If fso.FileExists(tempPath) Then fso.DeleteFile tempPath, True
        On Error GoTo ErrHandler
    Next i

    If keyCount = 0 Then
        MsgBox "データが見つかりませんでした。", vbExclamation
        GoTo Cleanup
    End If

    ' --- keyList を実サイズに切り詰め ---
    If keyCount < UBound(keyList) Then
        ReDim Preserve keyList(1 To keyCount)
    End If


    ' ==========================================================
    '  4. シェルソート（SORT_KEY_1～5 の多段比較）
    '     バブルソート O(n^2) からシェルソート O(n^1.3) に高速化
    ' ==========================================================
    Dim va As Variant, vb As Variant
    Dim sk As Long
    Dim needSwap As Boolean
    Dim gap As Long, gi As Long, gj As Long
    Dim tmp As String

    gap = keyCount \ 2
    Do While gap > 0
        For gi = gap + 1 To keyCount
            tmp = keyList(gi)
            Dim tmpSort As Variant
            tmpSort = sortDict(tmp)
            gj = gi
            Do While gj > gap
                vb = sortDict(keyList(gj - gap))
                needSwap = False
                For sk = 0 To 4
                    If vb(sk) <> tmpSort(sk) Then
                        needSwap = (vb(sk) > tmpSort(sk))
                        Exit For
                    End If
                Next sk
                If Not needSwap Then Exit Do
                keyList(gj) = keyList(gj - gap)
                gj = gj - gap
            Loop
            keyList(gj) = tmp
        Next gi
        gap = gap \ 2
    Loop


    ' ==========================================================
    '  5. output1 : クロスリファレンス表を出力
    '     ソース全列(A～CN)のデータを表示し、
    '     B～I列のみ n1～n8 の〇マークで上書きする。
    ' ==========================================================
    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("output1")
    ws1.Cells.Clear

    Dim out1() As Variant
    Dim outCols As Long
    outCols = SRC_LAST_COL

    ReDim out1(1 To keyCount + 1, 1 To outCols)

    ' --- ヘッダ行：ソースのヘッダをコピーし、B～I列のみ上書き ---
    Dim parts() As String
    If Not IsEmpty(hdrRow) Then
        For c = 1 To outCols
            out1(1, c) = hdrRow(1, c)
        Next c
    End If
    For i = 1 To nFiles
        out1(1, OUT_COL_N + i - 1) = srcNames(i)
    Next i

    ' --- データ行：全列データをコピーし、B～I列のみ〇で上書き ---
    Dim rowData As Variant
    Dim cRef As Object

    For r = 1 To keyCount
        rowData = rowDict(keyList(r))
        For c = 1 To outCols
            out1(r + 1, c) = rowData(c)
        Next c

        ' B～I列を〇で上書き（Dictionary参照を変数にキャッシュ）
        Set cRef = crossRef(keyList(r))
        For i = 1 To nFiles
            If cRef.Exists(srcNames(i)) Then
                out1(r + 1, OUT_COL_N + i - 1) = MARU
            Else
                out1(r + 1, OUT_COL_N + i - 1) = ""
            End If
        Next i
    Next r

    ws1.Range(ws1.Cells(OUT_HDR_ROW, 1), _
              ws1.Cells(OUT_HDR_ROW + keyCount, outCols)).Value = out1

    ' --- B4～I4（n列ヘッダ）を縦書き表示にする ---
    Dim lastNCol As Long
    lastNCol = OUT_COL_N + nFiles - 1
    If lastNCol > 9 Then lastNCol = 9
    If lastNCol >= OUT_COL_N Then
        ws1.Range(ws1.Cells(OUT_HDR_ROW, OUT_COL_N), _
                  ws1.Cells(OUT_HDR_ROW, lastNCol)).Orientation = 90
    End If

    ' --- out1 配列を解放（メモリ節約） ---
    Erase out1


    ' ==========================================================
    '  6. output2 : キーごとのメモ集約表を出力
    '     1列目: no（ソースのT列）
    '     2列目: name（ソースのZ列）
    '     3列目: 備考（コメント集約）
    '     ※ OUT2_KEY_FROM / OUT2_KEY_TO で範囲フィルタ可能
    ' ==========================================================
    Dim ws2 As Worksheet
    Set ws2 = ThisWorkbook.Sheets("output2")
    ws2.Cells.Clear

    ' --- キーごとにコメント・no・nameを集約する Dictionary ---
    Dim fnDict   As Object    ' キー値 → 結合メモ文字列
    Dim fnNoDict As Object    ' キー値 → no（初回出現時のT列値）
    Dim fnNmDict As Object    ' キー値 → name（初回出現時のZ列値）
    Dim fnList() As String    ' 出現順のキーリスト
    Dim fnCount  As Long
    Set fnDict = CreateObject("Scripting.Dictionary")
    Set fnNoDict = CreateObject("Scripting.Dictionary")
    Set fnNmDict = CreateObject("Scripting.Dictionary")
    ReDim fnList(1 To keyCount)   ' 最大でkeyCount個
    fnCount = 0

    For r = 1 To keyCount
        parts = Split(keyList(r), SEP)
        keyVal = parts(0)
        cmnt = ""
        If UBound(parts) >= 1 Then cmnt = parts(1)

        ' ★ output2 専用：キー値トリム処理
        If FNAME_TRIM_PREFIX <> "" Then
            If Left(keyVal, Len(FNAME_TRIM_PREFIX)) = FNAME_TRIM_PREFIX Then
                keyVal = Mid(keyVal, Len(FNAME_TRIM_PREFIX) + 1)
            End If
        End If
        If FNAME_TRIM_SUFFIX <> "" Then
            If Right(keyVal, Len(FNAME_TRIM_SUFFIX)) = FNAME_TRIM_SUFFIX Then
                keyVal = Left(keyVal, Len(keyVal) - Len(FNAME_TRIM_SUFFIX))
            End If
        End If

        ' ★ 範囲フィルタ
        Dim inRange As Boolean
        inRange = True
        If OUT2_KEY_FROM <> "" Then
            If keyVal < OUT2_KEY_FROM Then inRange = False
        End If
        If OUT2_KEY_TO <> "" Then
            If keyVal > OUT2_KEY_TO Then inRange = False
        End If

        If inRange Then

            ' --- 全ソースに存在するか判定 ---
            Dim allOK    As Boolean
            Dim presList As String
            Dim sName    As String
            allOK = True
            presList = ""

            Set cRef = crossRef(keyList(r))
            For i = 1 To nFiles
                If cRef.Exists(srcNames(i)) Then
                    sName = srcNames(i)
                    If FNAME_TRIM_PREFIX <> "" Then
                        If Left(sName, Len(FNAME_TRIM_PREFIX)) = FNAME_TRIM_PREFIX Then
                            sName = Mid(sName, Len(FNAME_TRIM_PREFIX) + 1)
                        End If
                    End If
                    If FNAME_TRIM_SUFFIX <> "" Then
                        If Right(sName, Len(FNAME_TRIM_SUFFIX)) = FNAME_TRIM_SUFFIX Then
                            sName = Left(sName, Len(sName) - Len(FNAME_TRIM_SUFFIX))
                        End If
                    End If
                    If presList <> "" Then presList = presList & ","
                    presList = presList & sName
                Else
                    allOK = False
                End If
            Next i

            ' --- メモ文字列生成 ---
            Dim entry As String
            Dim dispCmnt As String
            If cmnt <> "" Then
                dispCmnt = cmnt
            Else
                dispCmnt = "＿"
            End If

            If allOK Then
                entry = dispCmnt
            Else
                entry = dispCmnt & presList & NOMI
            End If

            ' --- 同じキー値のエントリを結合 ---
            If Not fnDict.Exists(keyVal) Then
                fnDict(keyVal) = entry
                fnCount = fnCount + 1
                fnList(fnCount) = keyVal

                ' ★ no(T列), name(Z列) を rowDict から取得（初回出現時）
                rowData = rowDict(keyList(r))
                fnNoDict(keyVal) = CStr(rowData(OUT2_COL_NO) & "")
                fnNmDict(keyVal) = CStr(rowData(OUT2_COL_NAME) & "")
            Else
                If entry <> "" Then
                    If fnDict(keyVal) <> "" Then
                        fnDict(keyVal) = fnDict(keyVal) & "  " & entry
                    Else
                        fnDict(keyVal) = entry
                    End If
                End If
            End If

        End If  ' inRange
    Next r

    ' --- 配列に詰めて一括書き込み（3列: no, name, 備考） ---
    If fnCount > 0 Then
        Dim out2() As Variant
        ReDim out2(1 To fnCount + 1, 1 To 3)
        out2(1, 1) = HDR_NO
        out2(1, 2) = HDR_NAME
        out2(1, 3) = HDR_MEMO

        For r = 1 To fnCount
            out2(r + 1, 1) = fnNoDict(fnList(r))
            out2(r + 1, 2) = fnNmDict(fnList(r))
            out2(r + 1, 3) = fnDict(fnList(r))
        Next r

        ws2.Range(ws2.Cells(1, 1), ws2.Cells(fnCount + 1, 3)).Value = out2
    End If


    ' ==========================================================
    '  完了メッセージ
    ' ==========================================================
    MsgBox "完了しました！" & vbCrLf & _
           "フォルダ: " & folderPath & vbCrLf & _
           "ソース: " & nFiles & " ファイル" & vbCrLf & _
           "output1: " & keyCount & " 行" & vbCrLf & _
           "output2: " & fnCount & " 行", vbInformation


Cleanup:
    ' ----------------------------------------------------------
    '  画面更新・再計算・イベントを復元
    ' ----------------------------------------------------------
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Exit Sub


ErrHandler:
    ' ----------------------------------------------------------
    '  予期しないエラーのハンドリング
    ' ----------------------------------------------------------
    MsgBox "エラーが発生しました: " & Err.Description & vbCrLf & _
           "パス: " & folderPath, vbCritical
    Resume Cleanup

End Sub


Option Explicit

' ============================================================
'  処理A : 部品リスト集約マクロ
'  ────────────────────────────────────────────────────────────
'  ・settingシートで指定したソースファイル(import/)を読み込み、
'    output1 に〇クロスリファレンス表（ソース全列）、
'    output2 にキーごとのメモ集約表を出力する。
'  ・配列一括 Read/Write ＋ シェルソートで高速処理
' ============================================================


Sub RunAggregate()

    ' ==========================================================
    '  定数定義：読み込み元（ソースファイル）の列番号
    '  ソースの列範囲は A(1)～CN(92)
    ' ==========================================================
    Const SRC_COL_KEY   As Long = 11  ' K列  : キー（集約キー）
    Const SRC_COL_CMNT  As Long = 27  ' AA列 : コメント
    Const SRC_LAST_COL  As Long = 92  ' CN列 : データ最終列
    Const SRC_START_ROW As Long = 5   ' データ開始行（4行目はヘッダ）

    ' ==========================================================
    '  定数定義：出力先（output1）の列番号・行番号
    ' ==========================================================
    Const OUT_COL_KEY   As Long = 11  ' K列  : キー表示位置
    Const OUT_COL_WORK  As Long = 27  ' AA列 : 作業（コメント）
    Const OUT_COL_N     As Long = 2   ' B列  : n列の開始位置
    Const OUT_HDR_ROW   As Long = 4   ' ヘッダ行（B4～I4 に n1,n2,...）

    ' ==========================================================
    '  定数定義：出力先（output2）の列番号
    '  1列目=キー(K列), 2列目=no(T列), 3列目=name(Z列), 4列目=備考
    ' ==========================================================
    Const OUT2_COL_NO   As Long = 20  ' T列  : no（ソースのT列から取得）
    Const OUT2_COL_NAME As Long = 26  ' Z列  : name（ソースのZ列から取得）

    ' ==========================================================
    '  定数定義：settingシートの巡回範囲
    ' ==========================================================
    Const START_ROW As Long = 2   ' ファイルリスト開始行
    Const END_ROW   As Long = 10  ' ファイルリスト終了行

    ' ==========================================================
    '  定数定義：ファイル名トリム（output2 専用）
    '  output2 出力時のみ、キー値の先頭・末尾を除去する。
    '  output1 には影響しない。
    '  不要なら "" にすればスキップされる。
    ' ==========================================================
    Const FNAME_TRIM_PREFIX As String = ""   ' 先頭から除去する文字列
    Const FNAME_TRIM_SUFFIX As String = ""   ' 末尾から除去する文字列

    ' ==========================================================
    '  定数定義：output2 キー範囲フィルタ
    '  output2 に出力するキーの範囲を指定する。
    '  文字列比較（昇順）で FROM ≦ キー ≦ TO の行のみ出力。
    '  空文字 "" なら制限なし（全キー出力）。
    '  例: "A00-0000" ～ "B99-9999" → A～B で始まるキーのみ
    ' ==========================================================
    Const OUT2_KEY_FROM As String = ""   ' 開始キー（空なら制限なし）
    Const OUT2_KEY_TO   As String = ""   ' 終了キー（空なら制限なし）

    ' ==========================================================
    '  定数定義：ソートキー（最大5段階）
    '  出力の並び順を制御する。列番号を指定（0 = 使わない）。
    '  例: K列(11)→O列(15)→N列(14) の順でソート
    ' ==========================================================
    Const SORT_KEY_1 As Long = 11   ' 第1キー: K列
    Const SORT_KEY_2 As Long = 15   ' 第2キー: O列
    Const SORT_KEY_3 As Long = 14   ' 第3キー: N列
    Const SORT_KEY_4 As Long = 0    ' 第4キー: なし
    Const SORT_KEY_5 As Long = 0    ' 第5キー: なし

    ' ==========================================================
    '  定数定義：区切り文字・日本語ラベル
    ' ==========================================================
    Const SEP As String = "|"

    Const MARU      As String = "〇"
    Const NOMI      As String = "のみ"
    Const HDR_KEY   As String = "キー"
    Const HDR_WORK  As String = "作業"
    Const HDR_NO    As String = "no"
    Const HDR_NAME  As String = "name"
    Const HDR_MEMO  As String = "備考"

    ' ==========================================================
    '  変数宣言
    ' ==========================================================
    Dim fso        As Object
    Dim folderPath As String
    Dim srcFiles() As String
    Dim srcNames() As String
    Dim nFiles     As Long
    Dim i          As Long
    Dim r          As Long
    Dim c          As Long

    ' ----------------------------------------------------------
    '  画面更新・再計算・イベントを一時停止（高速化）
    ' ----------------------------------------------------------
    Application.ScreenUpdating = False
    Application.Calculation = xlCalculationManual
    Application.EnableEvents = False
    On Error GoTo ErrHandler

    Set fso = CreateObject("Scripting.FileSystemObject")


    ' ==========================================================
    '  1. settingシート読み込み（必須）
    ' ==========================================================
    Dim wsSetting As Worksheet

    On Error Resume Next
    Set wsSetting = ThisWorkbook.Sheets("setting")
    On Error GoTo ErrHandler

    ' --- settingシートが無ければエラー終了 ---
    If wsSetting Is Nothing Then
        MsgBox "エラー: 'setting' シートが見つかりません。" & vbCrLf & _
               "settingシートを作成してください。", vbCritical
        GoTo Cleanup
    End If

    ' --- C1 からベースフォルダパスを取得 ---
    Dim baseFolder As String
    baseFolder = Trim(CStr(wsSetting.Cells(1, 3).Value & ""))

    If baseFolder <> "" Then
        If Right(baseFolder, 1) <> "\" Then baseFolder = baseFolder & "\"
        If Not fso.FolderExists(baseFolder) Then
            MsgBox "エラー: ベースフォルダが見つかりません:" & vbCrLf & _
                   baseFolder & vbCrLf & vbCrLf & _
                   "settingシートのC1を確認してください。", vbCritical
            GoTo Cleanup
        End If
        folderPath = baseFolder
    Else
        MsgBox "エラー: フォルダパスが取得できません。" & vbCrLf & _
               "settingシートのC1にベースフォルダパスを設定してください。", vbCritical
        GoTo Cleanup
    End If


    ' ==========================================================
    '  2. settingシートからファイルリストを取得
    '     （C列 START_ROW～END_ROW を巡回）
    ' ==========================================================
    If wsSetting.Cells(START_ROW, 3).Value = "" Then
        MsgBox "エラー: ファイルが設定されていません。" & vbCrLf & _
               "settingシートのC" & START_ROW & "以降にファイル名を入力してください。", vbCritical
        GoTo Cleanup
    End If

    ' --- 配列を事前確保（最大ファイル数 = END_ROW - START_ROW + 1） ---
    Dim maxFiles As Long
    maxFiles = END_ROW - START_ROW + 1
    ReDim srcFiles(1 To maxFiles)
    ReDim srcNames(1 To maxFiles)

    nFiles = 0
    Dim si As Long, sj As Long, st As String
    Dim cellVal     As String
    Dim fullPath    As String
    Dim missingFiles As String
    missingFiles = ""

    For r = START_ROW To END_ROW
        cellVal = Trim(CStr(wsSetting.Cells(r, 3).Value & ""))

        If cellVal <> "" Then
            If InStr(cellVal, "\") > 0 Or InStr(cellVal, "/") > 0 Then
                fullPath = cellVal
            Else
                fullPath = folderPath & cellVal
            End If

            If Not fso.FileExists(fullPath) Then
                missingFiles = missingFiles & "  行 " & r & ": " & cellVal & vbCrLf
            Else
                nFiles = nFiles + 1
                srcFiles(nFiles) = fullPath

                Dim dispName As String
                dispName = Trim(CStr(wsSetting.Cells(r, 2).Value & ""))
                If dispName = "" Then
                    Dim bName As String
                    bName = fso.GetFileName(fullPath)
                    If InStr(bName, "_n") > 0 Then
                        Dim nm As String
                        nm = Mid(bName, InStr(bName, "_n") + 2)
                        dispName = "n" & Left(nm, Len(nm) - 5)
                    Else
                        dispName = Left(bName, Len(bName) - 5)
                    End If
                End If
                srcNames(nFiles) = dispName
            End If
        End If
    Next r

    If missingFiles <> "" Then
        MsgBox "エラー: 以下のファイルが見つかりません:" & vbCrLf & vbCrLf & _
               missingFiles & vbCrLf & _
               "ベースフォルダ: " & folderPath, vbCritical
        GoTo Cleanup
    End If

    If nFiles = 0 Then
        MsgBox "エラー: 有効なファイルがありません。", vbCritical
        GoTo Cleanup
    End If


    ' ==========================================================
    '  3. 全ソースファイル読み込み → Dictionaryに格納
    '     key = "K列値|コメント"
    '     value = Dictionary (ソース名 → True)
    '     ※ K列に値がある行を全て対象とする（〇フィルタなし）
    ' ==========================================================
    Dim crossRef As Object           ' 全キーのクロスリファレンス
    Set crossRef = CreateObject("Scripting.Dictionary")

    ' --- ソート用：各compKeyのソートキー値を保持 ---
    Dim sortDict As Object
    Set sortDict = CreateObject("Scripting.Dictionary")

    ' --- output1用：各compKeyの全列データを保持（初回出現時） ---
    Dim rowDict As Object
    Set rowDict = CreateObject("Scripting.Dictionary")

    ' --- output1用：ソースのヘッダ行（最初のファイルから取得） ---
    Dim hdrRow As Variant
    hdrRow = Empty

    ' --- キーリスト：事前確保して後で切り詰め ---
    Const INIT_KEYS As Long = 1024
    Dim keyList() As String
    Dim keyCount As Long
    ReDim keyList(1 To INIT_KEYS)
    keyCount = 0

    Dim srcWb   As Workbook
    Dim data    As Variant
    Dim lastRow As Long
    Dim keyVal  As String
    Dim cmnt    As String
    Dim compKey As String

    ' --- 共有ドライブ高速化：ローカルTEMPにコピーしてから読む ---
    Dim tempDir  As String
    Dim tempPath As String
    tempDir = Environ("TEMP")
    If Right(tempDir, 1) <> "\" Then tempDir = tempDir & "\"

    For i = 1 To nFiles

        ' ★ ネットワークファイルをローカルにコピー（一括転送で高速）
        tempPath = tempDir & fso.GetFileName(srcFiles(i))
        On Error Resume Next
        fso.CopyFile srcFiles(i), tempPath, True
        On Error GoTo ErrHandler

        ' ローカルコピーがあればそちらを開く、なければ元パスを開く
        Dim openPath As String
        If fso.FileExists(tempPath) Then
            openPath = tempPath
        Else
            openPath = srcFiles(i)
        End If

        Set srcWb = Workbooks.Open(openPath, ReadOnly:=True, UpdateLinks:=0)

        With srcWb.Sheets(1)
            lastRow = .Cells(.Rows.Count, SRC_COL_KEY).End(xlUp).Row

            If lastRow >= SRC_START_ROW Then

                ' --- ヘッダ行を最初のファイルから取得（1行前 = 4行目） ---
                If IsEmpty(hdrRow) Then
                    hdrRow = .Range(.Cells(SRC_START_ROW - 1, 1), _
                                    .Cells(SRC_START_ROW - 1, SRC_LAST_COL)).Value
                End If

                ' --- A列～CN列 を配列に一括読み込み ---
                data = .Range(.Cells(SRC_START_ROW, 1), .Cells(lastRow, SRC_LAST_COL)).Value

                For r = 1 To UBound(data, 1)

                    keyVal = Trim(CStr(data(r, SRC_COL_KEY) & ""))

                    If keyVal <> "" Then

                        If IsEmpty(data(r, SRC_COL_CMNT)) Or _
                           CStr(data(r, SRC_COL_CMNT) & "") = "" Then
                            cmnt = ""
                        Else
                            cmnt = CStr(data(r, SRC_COL_CMNT))
                        End If

                        compKey = keyVal & SEP & cmnt

                        If Not crossRef.Exists(compKey) Then
                            Set crossRef(compKey) = CreateObject("Scripting.Dictionary")
                            keyCount = keyCount + 1

                            ' 配列が足りなければ倍に拡張
                            If keyCount > UBound(keyList) Then
                                ReDim Preserve keyList(1 To UBound(keyList) * 2)
                            End If
                            keyList(keyCount) = compKey

                            ' ★ 全列データを保持（初回出現時の値を使用）
                            Dim rv As Variant
                            ReDim rv(1 To SRC_LAST_COL)
                            For c = 1 To SRC_LAST_COL
                                rv(c) = data(r, c)
                            Next c
                            rowDict(compKey) = rv

                            ' ★ ソート用の値を保持
                            Dim sv As Variant
                            sv = Array("", "", "", "", "")
                            If SORT_KEY_1 > 0 Then sv(0) = CStr(data(r, SORT_KEY_1) & "")
                            If SORT_KEY_2 > 0 Then sv(1) = CStr(data(r, SORT_KEY_2) & "")
                            If SORT_KEY_3 > 0 Then sv(2) = CStr(data(r, SORT_KEY_3) & "")
                            If SORT_KEY_4 > 0 Then sv(3) = CStr(data(r, SORT_KEY_4) & "")
                            If SORT_KEY_5 > 0 Then sv(4) = CStr(data(r, SORT_KEY_5) & "")
                            sortDict(compKey) = sv
                        End If

                        crossRef(compKey)(srcNames(i)) = True
                    End If
                Next r
            End If
        End With

        srcWb.Close False

        ' ★ TEMPのコピーを削除（後片付け）
        On Error Resume Next
        If fso.FileExists(tempPath) Then fso.DeleteFile tempPath, True
        On Error GoTo ErrHandler
    Next i

    If keyCount = 0 Then
        MsgBox "データが見つかりませんでした。", vbExclamation
        GoTo Cleanup
    End If

    ' --- keyList を実サイズに切り詰め ---
    If keyCount < UBound(keyList) Then
        ReDim Preserve keyList(1 To keyCount)
    End If


    ' ==========================================================
    '  4. シェルソート（SORT_KEY_1～5 の多段比較）
    '     バブルソート O(n^2) からシェルソート O(n^1.3) に高速化
    ' ==========================================================
    Dim va As Variant, vb As Variant
    Dim sk As Long
    Dim needSwap As Boolean
    Dim gap As Long, gi As Long, gj As Long
    Dim tmp As String

    gap = keyCount \ 2
    Do While gap > 0
        For gi = gap + 1 To keyCount
            tmp = keyList(gi)
            Dim tmpSort As Variant
            tmpSort = sortDict(tmp)
            gj = gi
            Do While gj > gap
                vb = sortDict(keyList(gj - gap))
                needSwap = False
                For sk = 0 To 4
                    If vb(sk) <> tmpSort(sk) Then
                        needSwap = (vb(sk) > tmpSort(sk))
                        Exit For
                    End If
                Next sk
                If Not needSwap Then Exit Do
                keyList(gj) = keyList(gj - gap)
                gj = gj - gap
            Loop
            keyList(gj) = tmp
        Next gi
        gap = gap \ 2
    Loop


    ' ==========================================================
    '  5. output1 : クロスリファレンス表を出力
    '     ソース全列(A～CN)のデータを表示し、
    '     B～I列のみ n1～n8 の〇マークで上書きする。
    ' ==========================================================
    Dim ws1 As Worksheet
    Set ws1 = ThisWorkbook.Sheets("output1")
    ws1.Cells.Clear

    Dim out1() As Variant
    Dim outCols As Long
    outCols = SRC_LAST_COL

    ReDim out1(1 To keyCount + 1, 1 To outCols)

    ' --- ヘッダ行：ソースのヘッダをコピーし、B～I列のみ上書き ---
    Dim parts() As String
    If Not IsEmpty(hdrRow) Then
        For c = 1 To outCols
            out1(1, c) = hdrRow(1, c)
        Next c
    End If
    For i = 1 To nFiles
        out1(1, OUT_COL_N + i - 1) = srcNames(i)
    Next i

    ' --- データ行：全列データをコピーし、B～I列のみ〇で上書き ---
    Dim rowData As Variant
    Dim cRef As Object

    For r = 1 To keyCount
        rowData = rowDict(keyList(r))
        For c = 1 To outCols
            out1(r + 1, c) = rowData(c)
        Next c

        ' B～I列を〇で上書き（Dictionary参照を変数にキャッシュ）
        Set cRef = crossRef(keyList(r))
        For i = 1 To nFiles
            If cRef.Exists(srcNames(i)) Then
                out1(r + 1, OUT_COL_N + i - 1) = MARU
            Else
                out1(r + 1, OUT_COL_N + i - 1) = ""
            End If
        Next i
    Next r

    ws1.Range(ws1.Cells(OUT_HDR_ROW, 1), _
              ws1.Cells(OUT_HDR_ROW + keyCount, outCols)).Value = out1

    ' --- B4～I4（n列ヘッダ）を縦書き表示にする ---
    Dim lastNCol As Long
    lastNCol = OUT_COL_N + nFiles - 1
    If lastNCol > 9 Then lastNCol = 9
    If lastNCol >= OUT_COL_N Then
        ws1.Range(ws1.Cells(OUT_HDR_ROW, OUT_COL_N), _
                  ws1.Cells(OUT_HDR_ROW, lastNCol)).Orientation = 90
    End If

    ' --- out1 配列を解放（メモリ節約） ---
    Erase out1


    ' ==========================================================
    '  6. output2 : キーごとのメモ集約表を出力
    '     1列目: キー（ソースのK列）
    '     2列目: no（ソースのT列）
    '     3列目: name（ソースのZ列）
    '     4列目: 備考（コメント集約）
    '     ※ OUT2_KEY_FROM / OUT2_KEY_TO で範囲フィルタ可能
    ' ==========================================================
    Dim ws2 As Worksheet
    Set ws2 = ThisWorkbook.Sheets("output2")
    ws2.Cells.Clear

    ' --- キーごとにコメント・no・nameを集約する Dictionary ---
    Dim fnDict   As Object    ' キー値 → 結合メモ文字列
    Dim fnNoDict As Object    ' キー値 → no（初回出現時のT列値）
    Dim fnNmDict As Object    ' キー値 → name（初回出現時のZ列値）
    Dim fnList() As String    ' 出現順のキーリスト
    Dim fnCount  As Long
    Set fnDict = CreateObject("Scripting.Dictionary")
    Set fnNoDict = CreateObject("Scripting.Dictionary")
    Set fnNmDict = CreateObject("Scripting.Dictionary")
    ReDim fnList(1 To keyCount)   ' 最大でkeyCount個
    fnCount = 0

    For r = 1 To keyCount
        parts = Split(keyList(r), SEP)
        keyVal = parts(0)
        cmnt = ""
        If UBound(parts) >= 1 Then cmnt = parts(1)

        ' ★ output2 専用：キー値トリム処理
        If FNAME_TRIM_PREFIX <> "" Then
            If Left(keyVal, Len(FNAME_TRIM_PREFIX)) = FNAME_TRIM_PREFIX Then
                keyVal = Mid(keyVal, Len(FNAME_TRIM_PREFIX) + 1)
            End If
        End If
        If FNAME_TRIM_SUFFIX <> "" Then
            If Right(keyVal, Len(FNAME_TRIM_SUFFIX)) = FNAME_TRIM_SUFFIX Then
                keyVal = Left(keyVal, Len(keyVal) - Len(FNAME_TRIM_SUFFIX))
            End If
        End If

        ' ★ output2 専用：ハイフン以降を除去（表示・集約キー）
        Dim hypPos As Long
        hypPos = InStr(keyVal, "-")
        If hypPos > 0 Then keyVal = Left(keyVal, hypPos - 1)

        ' ★ 範囲フィルタ
        Dim inRange As Boolean
        inRange = True
        If OUT2_KEY_FROM <> "" Then
            If keyVal < OUT2_KEY_FROM Then inRange = False
        End If
        If OUT2_KEY_TO <> "" Then
            If keyVal > OUT2_KEY_TO Then inRange = False
        End If

        If inRange Then

            ' --- 全ソースに存在するか判定 ---
            Dim allOK    As Boolean
            Dim presList As String
            Dim sName    As String
            allOK = True
            presList = ""

            Set cRef = crossRef(keyList(r))
            For i = 1 To nFiles
                If cRef.Exists(srcNames(i)) Then
                    sName = srcNames(i)
                    If FNAME_TRIM_PREFIX <> "" Then
                        If Left(sName, Len(FNAME_TRIM_PREFIX)) = FNAME_TRIM_PREFIX Then
                            sName = Mid(sName, Len(FNAME_TRIM_PREFIX) + 1)
                        End If
                    End If
                    If FNAME_TRIM_SUFFIX <> "" Then
                        If Right(sName, Len(FNAME_TRIM_SUFFIX)) = FNAME_TRIM_SUFFIX Then
                            sName = Left(sName, Len(sName) - Len(FNAME_TRIM_SUFFIX))
                        End If
                    End If
                    If presList <> "" Then presList = presList & ","
                    presList = presList & sName
                Else
                    allOK = False
                End If
            Next i

            ' --- メモ文字列生成 ---
            Dim entry As String
            Dim dispCmnt As String
            If cmnt <> "" Then
                dispCmnt = cmnt
            Else
                dispCmnt = "＿"
            End If

            If allOK Then
                entry = dispCmnt
            Else
                entry = dispCmnt & presList & NOMI
            End If

            ' --- 同じキー値のエントリを結合 ---
            If Not fnDict.Exists(keyVal) Then
                fnDict(keyVal) = entry
                fnCount = fnCount + 1
                fnList(fnCount) = keyVal

                ' ★ no(T列), name(Z列) を rowDict から取得（初回出現時）
                rowData = rowDict(keyList(r))
                fnNoDict(keyVal) = CStr(rowData(OUT2_COL_NO) & "")
                fnNmDict(keyVal) = CStr(rowData(OUT2_COL_NAME) & "")
            Else
                If entry <> "" Then
                    If fnDict(keyVal) <> "" Then
                        fnDict(keyVal) = fnDict(keyVal) & "  " & entry
                    Else
                        fnDict(keyVal) = entry
                    End If
                End If
            End If

        End If  ' inRange
    Next r

    ' --- 配列に詰めて一括書き込み（4列: キー, no, name, 備考） ---
    If fnCount > 0 Then
        Dim out2() As Variant
        ReDim out2(1 To fnCount + 1, 1 To 4)
        out2(1, 1) = HDR_KEY
        out2(1, 2) = HDR_NO
        out2(1, 3) = HDR_NAME
        out2(1, 4) = HDR_MEMO

        For r = 1 To fnCount
            out2(r + 1, 1) = fnList(r)
            out2(r + 1, 2) = fnNoDict(fnList(r))
            out2(r + 1, 3) = fnNmDict(fnList(r))
            out2(r + 1, 4) = fnDict(fnList(r))
        Next r

        ws2.Range(ws2.Cells(1, 1), ws2.Cells(fnCount + 1, 4)).Value = out2
    End If


    ' ==========================================================
    '  完了メッセージ
    ' ==========================================================
    MsgBox "完了しました！" & vbCrLf & _
           "フォルダ: " & folderPath & vbCrLf & _
           "ソース: " & nFiles & " ファイル" & vbCrLf & _
           "output1: " & keyCount & " 行" & vbCrLf & _
           "output2: " & fnCount & " 行", vbInformation


Cleanup:
    ' ----------------------------------------------------------
    '  画面更新・再計算・イベントを復元
    ' ----------------------------------------------------------
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Exit Sub


ErrHandler:
    ' ----------------------------------------------------------
    '  予期しないエラーのハンドリング
    ' ----------------------------------------------------------
    MsgBox "エラーが発生しました: " & Err.Description & vbCrLf & _
           "パス: " & folderPath, vbCritical
    Resume Cleanup

End Sub

]]> https://manabinotes.com/%e3%80%90vba%e3%80%91%e5%be%ae%e5%a6%99%e3%81%ab%e9%81%95%e3%81%86%e3%83%95%e3%82%a1%e3%82%a4%e3%83%ab%e3%81%ae%e6%af%94%e8%bc%83%e9%9b%86%e7%b4%84/feed/ 0 【PAD】 PDFの向きと大きさを揃えて印刷しなおす https://manabinotes.com/%e3%80%90pad%e3%80%91-pdf%e3%81%ae%e5%90%91%e3%81%8d%e3%81%a8%e5%a4%a7%e3%81%8d%e3%81%95%e3%82%92%e6%8f%83%e3%81%88%e3%81%a6%e5%8d%b0%e5%88%b7%e3%81%97%e3%81%aa%e3%81%8a%e3%81%99/ https://manabinotes.com/%e3%80%90pad%e3%80%91-pdf%e3%81%ae%e5%90%91%e3%81%8d%e3%81%a8%e5%a4%a7%e3%81%8d%e3%81%95%e3%82%92%e6%8f%83%e3%81%88%e3%81%a6%e5%8d%b0%e5%88%b7%e3%81%97%e3%81%aa%e3%81%8a%e3%81%99/#respond Mon, 23 Feb 2026 14:32:13 +0000 https://manabinotes.com/?p=235

PDF統合印刷ダウンロード

↓「プリンタの余白に合わせる」「用紙に合わせて自動回転:ON」「ドキュメントのページサイズで用紙サイズを選択:OFF」が重要！！

]]> https://manabinotes.com/%e3%80%90pad%e3%80%91-pdf%e3%81%ae%e5%90%91%e3%81%8d%e3%81%a8%e5%a4%a7%e3%81%8d%e3%81%95%e3%82%92%e6%8f%83%e3%81%88%e3%81%a6%e5%8d%b0%e5%88%b7%e3%81%97%e3%81%aa%e3%81%8a%e3%81%99/feed/ 0 【VBA】スニペット集 https://manabinotes.com/%e3%80%90vba%e3%80%91%e3%82%bf%e3%82%a4%e3%83%88%e3%83%abonedrive-url-%e2%86%92-%e3%83%ad%e3%83%bc%e3%82%ab%e3%83%ab%e3%83%91%e3%82%b9%e5%a4%89%e6%8f%9b%e3%82%bf%e3%82%a4%e3%83%88%e3%83%ab/ https://manabinotes.com/%e3%80%90vba%e3%80%91%e3%82%bf%e3%82%a4%e3%83%88%e3%83%abonedrive-url-%e2%86%92-%e3%83%ad%e3%83%bc%e3%82%ab%e3%83%ab%e3%83%91%e3%82%b9%e5%a4%89%e6%8f%9b%e3%82%bf%e3%82%a4%e3%83%88%e3%83%ab/#respond Mon, 23 Feb 2026 08:26:47 +0000 https://manabinotes.com/?p=230 使いまわしよう

OneDrive URL → ローカルパス変換

' ── OneDrive URL → ローカルパス変換 ──
Private Function GetLocalPath() As String
    Dim p As String
    p = ThisWorkbook.Path

    ' URLでなければそのまま返す
    If Left(p, 4) <> "http" Then
        GetLocalPath = p & "\"
        Exit Function
    End If

    ' OneDrive環境変数からローカルパスを推定
    Dim envKeys As Variant
    envKeys = Array("OneDriveConsumer", "OneDriveCommercial", "OneDrive")

    Dim ws As Object
    Set ws = CreateObject("WScript.Shell")

    Dim envPath As String, i As Long
    For i = 0 To UBound(envKeys)
        On Error Resume Next
        envPath = ws.Environment("Process")(CStr(envKeys(i)))
        On Error GoTo 0
        If envPath <> "" Then
            Dim urlPath As String
            urlPath = p

            ' URLベース部分を除去 (https://domain/id/ の4番目の/以降)
            Dim slashPos As Long, cnt As Long
            slashPos = 0
            For cnt = 1 To 4
                slashPos = InStr(slashPos + 1, urlPath, "/")
                If slashPos = 0 Then Exit For
            Next
            If slashPos > 0 Then
                urlPath = Mid(urlPath, slashPos + 1)
            End If

            ' %XX をデコード
            urlPath = URLDecode(urlPath)

            ' / → \ に置換
            urlPath = Replace(urlPath, "/", "\")

            ' ローカルパス候補を生成して存在確認
            Dim localCandidate As String
            localCandidate = envPath & "\" & urlPath & "\"

            Dim fso As Object
            Set fso = CreateObject("Scripting.FileSystemObject")
            If fso.FolderExists(localCandidate) Then
                GetLocalPath = localCandidate
                Exit Function
            End If

            ' 最初のサブフォルダを除いた候補も試す (OneDriveの階層ズレ対策)
            Dim firstSlash As Long
            firstSlash = InStr(urlPath, "\")
            If firstSlash > 0 Then
                localCandidate = envPath & "\" & Mid(urlPath, firstSlash + 1) & "\"
                If fso.FolderExists(localCandidate) Then
                    GetLocalPath = localCandidate
                    Exit Function
                End If
            End If
        End If
    Next

    ' 自動解決失敗時: フォルダ選択ダイアログ
    With Application.FileDialog(4)
        .Title = "Select dwglist folder"
        If .Show = -1 Then
            GetLocalPath = .SelectedItems(1) & "\"
        Else
            GetLocalPath = ""
        End If
    End With
End Function

' ── URLデコード (%XX → 文字) ──
Private Function URLDecode(ByVal s As String) As String
    Dim result As String, i As Long
    i = 1
    Do While i <= Len(s)
        If Mid(s, i, 1) = "%" And i + 2 <= Len(s) Then
            result = result & Chr(Val("&H" & Mid(s, i + 1, 2)))
            i = i + 3
        Else
            result = result & Mid(s, i, 1)
            i = i + 1
        End If
    Loop
    URLDecode = result
End Function

クリーンUP

Cleanup:
    ' 画面更新・再計算・イベントを復元
    Application.ScreenUpdating = True
    Application.Calculation = xlCalculationAutomatic
    Application.EnableEvents = True
    Exit Sub

ErrHandler:
    MsgBox "Error: " & Err.Description & vbCrLf & _
           "Path: " & folderPath, vbCritical
    Resume Cleanup
End Sub

]]> https://manabinotes.com/%e3%80%90vba%e3%80%91%e3%82%bf%e3%82%a4%e3%83%88%e3%83%abonedrive-url-%e2%86%92-%e3%83%ad%e3%83%bc%e3%82%ab%e3%83%ab%e3%83%91%e3%82%b9%e5%a4%89%e6%8f%9b%e3%82%bf%e3%82%a4%e3%83%88%e3%83%ab/feed/ 0