まなびの書 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】 PDFへのコメント追加スクリプトの生成 https://manabinotes.com/%e3%80%90vba%e3%80%91-pdf%e3%81%b8%e3%81%ae%e3%82%b3%e3%83%a1%e3%83%b3%e3%83%88%e8%bf%bd%e5%8a%a0%e3%82%b9%e3%82%af%e3%83%aa%e3%83%97%e3%83%88%e3%81%ae%e7%94%9f%e6%88%90/ https://manabinotes.com/%e3%80%90vba%e3%80%91-pdf%e3%81%b8%e3%81%ae%e3%82%b3%e3%83%a1%e3%83%b3%e3%83%88%e8%bf%bd%e5%8a%a0%e3%82%b9%e3%82%af%e3%83%aa%e3%83%97%e3%83%88%e3%81%ae%e7%94%9f%e6%88%90/#respond Sun, 01 Mar 2026 19:08:08 +0000 https://manabinotes.com/?p=282 全体フロー 
Excel（コメント一覧）
       ↓  VBAマクロ実行（Alt+F8）
JavaScript コード生成 → クリップボードへ自動コピー
       ↓  PDF-XChange Editor で Ctrl+J → Ctrl+V → Enter
PDF 各ページにコメント追加完了 → Ctrl+S で保存

初回セットアップ（1回だけ）

  1. コメント一覧_テンプレート_v3.xlsx を開く
  2. Alt+F11（VBAエディタを開く）
  3. 挿入 → 標準モジュール
  4. VBAコードを貼り付け
  5. VBAエディタを閉じる
  6. 名前を付けて保存 → 種類を 「Excel マクロ有効ブック (.xlsm)」 で保存

毎回の操作

Step 1: Excel でデータ入力

「コメント一覧」シートに入力（1行目はヘッダー）

A列（図番）B列（コメント）
DWG-001承認済み
DWG-002要修正：寸法確認

※ 2行目 → PDFの1ページ目、3行目 → 2ページ目 … と対応

Step 2: 設定を調整（任意）

「設定」シートでドロップダウンから選択

項目初期値選択肢
フォントサイズ108～14 推奨
フォントHelvBHelvB / Helv / Cour / CourB / Times / TimesB
文字色redred / blue / black / green
背景色whitewhite / yellow / none（透明）
枠線なしあり / なし
枠線色blackred / blue / black / green
位置左上左上 / 右上 / 左下 / 右下

Step 3: マクロ実行

Alt+F8 → 「JS生成_クリップボードコピー」→ 実行

→ JavaScriptが自動でクリップボードにコピーされる

Step 4: PDF-XChange Editor で貼り付け

  1. PDFを開く
  2. Ctrl+J（JSコンソールを開く）
  3. Ctrl+V（貼り付け）
  4. Enter（実行）→ 完了ダイアログ
  5. Ctrl+S（保存）

技術ポイント

VBAマクロの役割

  • Excelの「コメント一覧」シートから図番・コメントを読み取り
  • 「設定」シートからフォント・色・位置の設定を読み取り
  • PDF-XChange Editor の JSコンソールで実行可能な JavaScript を自動生成
  • 生成したコードをクリップボードにコピー

生成される JavaScript の処理内容

  • this.numPages で PDF の総ページ数を取得
  • 各ページの寸法を this.getPageBox("Crop", i) で取得
  • テキスト幅を全角/半角で自動計算（全角=fontSize幅、半角=fontSize×0.55）
  • 指定位置（左上/右上/左下/右下）に応じた座標を算出
  • this.addAnnot() で FreeText アノテーションとして追加

必要な環境

  • Excel（マクロ有効）
  • PDF-XChange Editor（無料版OK）
  • 追加インストール：なし

コメント一覧_テンプレート_v3ダウンロード
Sub JS生成_クリップボードコピー()
    '-------------------------------------------
    ' PDFコメント貼付ツール - JS生成マクロ（回転対応版）
    '-------------------------------------------
    Dim wsData As Worksheet
    Dim wsSetting As Worksheet
    Dim fontSize As Long
    Dim textColor As String

    Set wsData = ThisWorkbook.Sheets("コメント一覧")

    ' 設定読み込み
    On Error Resume Next
    Set wsSetting = ThisWorkbook.Sheets("設定")
    On Error GoTo 0

    If Not wsSetting Is Nothing Then
        fontSize = wsSetting.Cells(2, 2).Value
        textColor = CStr(wsSetting.Cells(3, 2).Value)
    End If
    If fontSize = 0 Then fontSize = 10
    If textColor = "" Then textColor = "red"

    ' 色マッピング
    Dim jsColor As String
    Select Case LCase(textColor)
        Case "red":   jsColor = "color.red"
        Case "blue":  jsColor = "color.blue"
        Case "black": jsColor = "color.black"
        Case "green": jsColor = "color.green"
        Case Else:    jsColor = "color.red"
    End Select

    ' データ読み込み
    Dim row As Long
    Dim dataCount As Long
    row = 2
    dataCount = 0
    Do While wsData.Cells(row, 1).Value <> "" Or wsData.Cells(row, 2).Value <> ""
        dataCount = dataCount + 1
        row = row + 1
    Loop

    If dataCount = 0 Then
        MsgBox "コメントデータがありません。" & vbCrLf & _
               "「コメント一覧」シートの2行目以降にデータを入力してください。", vbExclamation
        Exit Sub
    End If

    ' JavaScript生成
    Dim js As String
    Dim Q As String
    Q = Chr(34) ' ダブルクォート

    js = "// PDF コメント貼付スクリプト（回転対応版）" & vbLf
    js = js & "// 生成: " & Format(Now, "yyyy/mm/dd hh:nn:ss") & vbLf
    js = js & "var comments = [" & vbLf

    row = 2
    Do While wsData.Cells(row, 1).Value <> "" Or wsData.Cells(row, 2).Value <> ""
        Dim figNum As String
        Dim comment As String
        Dim displayText As String

        figNum = CStr(wsData.Cells(row, 1).Value)
        comment = CStr(wsData.Cells(row, 2).Value)

        ' エスケープ
        displayText = Replace(comment, "\", "\\")
        displayText = Replace(displayText, Q, "\" & Q)

        If figNum <> "" Then
            figNum = Replace(figNum, "\", "\\")
            figNum = Replace(figNum, Q, "\" & Q)
            displayText = "[" & figNum & "] " & displayText
        End If

        js = js & "  " & Q & displayText & Q & "," & vbLf
        row = row + 1
    Loop

    js = js & "];" & vbLf
    js = js & "" & vbLf

    ' ============================================================
    ' 回転対応のコアロジック
    ' getPageBox は「PDFの生座標系（回転前）」を返す
    ' getPageRotation で回転角を取得し、座標を補正する
    '
    ' 各回転角での座標変換：
    '   回転0°  : そのまま。左上 = (x0, y1)
    '   回転90° : 幅と高さが入れ替わる。左上 = (y0, x1)
    '   回転180°: 左上が右下になる。左上 = (x1, y0)
    '   回転270°: 幅と高さが入れ替わり反転。左上 = (y1, x0)
    '
    ' 目標：どの回転でも「表示上の左上端」にコメントを配置する
    ' ============================================================

    js = js & "// ページ回転を考慮してrectを計算するヘルパー関数" & vbLf
    js = js & "function calcRect(box, rotation, textLen, fSize) {" & vbLf
    js = js & "  // box = [x0, y0, x1, y1] (PDF生座標系、左下原点)" & vbLf
    js = js & "  // x0,y0=左下  x1,y1=右上" & vbLf
    js = js & "  var x0 = box[0], y0 = box[1], x1 = box[2], y1 = box[3];" & vbLf
    js = js & "  var w = x1 - x0;  // ページ幅（生座標）" & vbLf
    js = js & "  var h = y1 - y0;  // ページ高さ（生座標）" & vbLf
    js = js & "  var margin = 8;" & vbLf
    js = js & "  var tW = textLen * fSize * 0.55;" & vbLf
    js = js & "  var tH = fSize + 4;" & vbLf
    js = js & "  var rx0, ry0, rx1, ry1;" & vbLf
    js = js & "  // 「表示上の左上」を生座標に変換してrectを組み立てる" & vbLf
    js = js & "  if (rotation === 0) {" & vbLf
    js = js & "    // 表示: 左上 = PDF座標(x0, y1)" & vbLf
    js = js & "    rx0 = x0 + margin;" & vbLf
    js = js & "    ry1 = y1 - margin;" & vbLf
    js = js & "    rx1 = rx0 + tW;" & vbLf
    js = js & "    ry0 = ry1 - tH;" & vbLf
    js = js & "  } else if (rotation === 90) {" & vbLf
    js = js & "    // 表示: 左上 = PDF座標(x0, y0)  ※幅と高さが見かけ上入れ替わる" & vbLf
    js = js & "    rx0 = x0 + margin;" & vbLf
    js = js & "    ry0 = y0 + margin;" & vbLf
    js = js & "    rx1 = rx0 + tH;" & vbLf
    js = js & "    ry1 = ry0 + tW;" & vbLf
    js = js & "  } else if (rotation === 180) {" & vbLf
    js = js & "    // 表示: 左上 = PDF座標(x1, y0)" & vbLf
    js = js & "    rx1 = x1 - margin;" & vbLf
    js = js & "    ry0 = y0 + margin;" & vbLf
    js = js & "    rx0 = rx1 - tW;" & vbLf
    js = js & "    ry1 = ry0 + tH;" & vbLf
    js = js & "  } else if (rotation === 270) {" & vbLf
    js = js & "    // 表示: 左上 = PDF座標(x1, y1)  ※幅と高さが見かけ上入れ替わる" & vbLf
    js = js & "    rx1 = x1 - margin;" & vbLf
    js = js & "    ry1 = y1 - margin;" & vbLf
    js = js & "    rx0 = rx1 - tH;" & vbLf
    js = js & "    ry0 = ry1 - tW;" & vbLf
    js = js & "  } else {" & vbLf
    js = js & "    // フォールバック（想定外の回転値）" & vbLf
    js = js & "    rx0 = x0 + margin;" & vbLf
    js = js & "    ry1 = y1 - margin;" & vbLf
    js = js & "    rx1 = rx0 + tW;" & vbLf
    js = js & "    ry0 = ry1 - tH;" & vbLf
    js = js & "  }" & vbLf
    js = js & "  return [rx0, ry0, rx1, ry1];" & vbLf
    js = js & "}" & vbLf
    js = js & "" & vbLf

    js = js & "var n = this.numPages;" & vbLf
    js = js & "var added = 0;" & vbLf
    js = js & "for (var i = 0; i " & Chr(60) & " n " & Chr(38) & Chr(38) & " i " & Chr(60) & " comments.length; i++) {" & vbLf
    js = js & "  if (comments[i] === " & Q & Q & ") continue;" & vbLf
    js = js & "  var page = this.getPageBox(" & Q & "Crop" & Q & ", i);" & vbLf
    js = js & "  var rot = this.getPageRotation(i);  // 0, 90, 180, 270 のいずれか" & vbLf
    js = js & "  var tLen = comments[i].length;" & vbLf
    js = js & "  var r = calcRect(page, rot, tLen, " & fontSize & ");" & vbLf
    js = js & "  this.addAnnot({" & vbLf
    js = js & "    type: " & Q & "FreeText" & Q & "," & vbLf
    js = js & "    page: i," & vbLf
    js = js & "    rect: r," & vbLf
    js = js & "    contents: comments[i]," & vbLf
    js = js & "    textFont: font.HelvB," & vbLf
    js = js & "    textSize: " & fontSize & "," & vbLf
    js = js & "    textColor: " & jsColor & "," & vbLf
    js = js & "    strokeColor: [" & Q & "RGB" & Q & ",1,1,1]," & vbLf
    js = js & "    fillColor: [" & Q & "RGB" & Q & ",1,1,1]," & vbLf
    js = js & "    opacity: 0.9," & vbLf
    js = js & "    borderEffectStyle: " & Q & Q & "," & vbLf
    js = js & "    width: 0" & vbLf
    js = js & "  });" & vbLf
    js = js & "  added++;" & vbLf
    js = js & "}" & vbLf
    js = js & "app.alert(" & Q & "完了！ " & Q & "+added+" & Q & " ページにコメントを追加しました。\nCtrl+S で保存してください。" & Q & ", 3);" & vbLf

    ' クリップボードにコピー（MSForms.DataObject使用）
    Dim objData As Object
    Set objData = CreateObject("new:{1C3B4210-F441-11CE-B9EA-00AA006B1A69}")
    objData.SetText js
    objData.PutInClipboard
    Set objData = Nothing

    MsgBox dataCount & " 件のコメントからJavaScriptを生成しました！（回転対応版）" & vbCrLf & vbCrLf & _
           "クリップボードにコピー済みです。" & vbCrLf & vbCrLf & _
           "【次の手順】" & vbCrLf & _
           "1. PDF-XChange Editor でPDFを開く" & vbCrLf & _
           "2. Ctrl+J (JSコンソール)" & vbCrLf & _
           "3. Ctrl+V (貼り付け)" & vbCrLf & _
           "4. Enter (実行)" & vbCrLf & _
           "5. Ctrl+S (保存)", vbInformation, "PDF コメント貼付ツール（回転対応版）"

End Sub
]]> https://manabinotes.com/%e3%80%90vba%e3%80%91-pdf%e3%81%b8%e3%81%ae%e3%82%b3%e3%83%a1%e3%83%b3%e3%83%88%e8%bf%bd%e5%8a%a0%e3%82%b9%e3%82%af%e3%83%aa%e3%83%97%e3%83%88%e3%81%ae%e7%94%9f%e6%88%90/feed/ 0 【VBA】日付をキーにした複数ファイルの収集 https://manabinotes.com/%e3%80%90vba%e3%80%91%e6%97%a5%e4%bb%98%e3%82%92%e3%82%ad%e3%83%bc%e3%81%ab%e3%81%97%e3%81%9f%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%e6%97%a5%e4%bb%98%e3%82%92%e3%82%ad%e3%83%bc%e3%81%ab%e3%81%97%e3%81%9f%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 17:42:31 +0000 https://manabinotes.com/?p=279 処理の流れ

設定シート（Excel）から条件を読み込み → バリデーション → ネットワーク上のフォルダをスキャン → 条件に合うPDFをローカルにコピー → ログ記録、という一連の流れです。

スキャンの仕組み

まず Dir("*.pdf") でファイル名だけを高速に一括取得し、次にファイル名が除外パターン（LL* など）に一致するものをスキップ。残ったファイルだけ FSO.GetFile で作成日を取得して日付範囲内かチェックします。除外パターンに一致したファイルはFSO呼び出し自体をスキップするので、ネットワーク越しのアクセスを減らせます。

安全対策

コピー先が \\ で始まるネットワークパスだとエラーで停止（共有フォルダへの誤コピー防止）。実行前に対象ファイル一覧・件数・除外件数を確認ダイアログで表示し、デフォルトが「いいえ」なので手が滑っても実行されません。

設定シートで指定できる項目

コピー元パス、コピー先ベースパス、日付フォルダ名（2026_0302 等）、ファイルパターン、作成日 From/To、サブフォルダ検索（デフォルトOFF）、除外ファイル名パターン（複数指定可）の7項目です。

ログ

実行ごとに「ログ」シートへ追記され、各ファイルの成功/失敗とエラー内容が記録されます。

PDFコピーツールダウンロード

'==============================================================================
' PDFデータ コピーツール
'
' 機能: 設定シートの条件に基づき、コピー元フォルダから対象ファイルを
'       コピー先のローカルフォルダへコピーする。
'
' 高速化: Dir()でファイル名を一括取得後、FSO.GetFileで作成日チェック
' 安全性: コピー先ローカル確認、実行前確認ダイアログ、ログ記録
'==============================================================================
Option Explicit
Option Compare Text  ' 大文字小文字を区別しない（Like演算子・文字列比較）

Private m_fso As Object
Private m_copyList As Collection
Private m_excludePatterns() As String
Private m_excludeCount As Long
Private m_fileExt As String
Private m_dateFrom As Date
Private m_dateTo As Date
Private m_totalScanned As Long
Private m_excludedFileCount As Long  ' 除外されたファイル数カウント

'==============================================================================
' メインマクロ: PDFデータコピー実行
'==============================================================================
Public Sub PDFデータコピー実行()

    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("設定")
    On Error GoTo 0
    If ws Is Nothing Then
        MsgBox "「設定」シートが見つかりません。", vbCritical, "エラー"
        Exit Sub
    End If

    '----------------------------------------------------------------------
    ' 設定値の読込
    '----------------------------------------------------------------------
    Dim srcPath As String:    srcPath = Trim(CStr(ws.Range("C4").Value))
    Dim dstBase As String:    dstBase = Trim(CStr(ws.Range("C5").Value))
    Dim dateFolder As String: dateFolder = Trim(CStr(ws.Range("C6").Value))
    m_fileExt = Trim(CStr(ws.Range("C7").Value))
    If m_fileExt = "" Then m_fileExt = "*.pdf"

    ' 日付の読込と検証
    If Not IsDate(ws.Range("C8").Value) Then
        MsgBox "作成日（From）に有効な日付を入力してください。", vbCritical, "入力エラー"
        ws.Range("C8").Select
        Exit Sub
    End If
    If Not IsDate(ws.Range("C9").Value) Then
        MsgBox "作成日（To）に有効な日付を入力してください。", vbCritical, "入力エラー"
        ws.Range("C9").Select
        Exit Sub
    End If
    m_dateFrom = CDate(ws.Range("C8").Value)
    m_dateTo = CDate(ws.Range("C9").Value)

    Dim recurse As Boolean
    On Error Resume Next
    recurse = CBool(ws.Range("C10").Value)
    On Error GoTo 0

    '----------------------------------------------------------------------
    ' 除外ファイル名パターンの読込
    '----------------------------------------------------------------------
    m_excludeCount = 0
    ReDim m_excludePatterns(0 To 99)
    Dim r As Long: r = 13
    Do While Trim(CStr(ws.Cells(r, 3).Value)) <> ""
        m_excludePatterns(m_excludeCount) = Trim(CStr(ws.Cells(r, 3).Value))
        m_excludeCount = m_excludeCount + 1
        r = r + 1
        If m_excludeCount > 99 Then Exit Do
    Loop

    '----------------------------------------------------------------------
    ' バリデーション
    '----------------------------------------------------------------------
    ' パス末尾の \ を除去
    If Len(srcPath) > 0 And Right(srcPath, 1) = "\" Then srcPath = Left(srcPath, Len(srcPath) - 1)
    If Len(dstBase) > 0 And Right(dstBase, 1) = "\" Then dstBase = Left(dstBase, Len(dstBase) - 1)

    ' 必須項目チェック
    If srcPath = "" Then
        MsgBox "コピー元フォルダが未入力です。", vbCritical, "入力エラー"
        ws.Range("C4").Select: Exit Sub
    End If
    If dstBase = "" Then
        MsgBox "コピー先ベースフォルダが未入力です。", vbCritical, "入力エラー"
        ws.Range("C5").Select: Exit Sub
    End If
    If dateFolder = "" Then
        MsgBox "日付フォルダ名が未入力です。", vbCritical, "入力エラー"
        ws.Range("C6").Select: Exit Sub
    End If

    ' コピー先がローカルか確認（ネットワークパス \\... を拒否）
    If Left(dstBase, 2) = "\\" Then
        MsgBox "【安全確認エラー】" & vbCrLf & vbCrLf & _
               "コピー先にネットワークパス（\\...）が指定されています。" & vbCrLf & _
               "誤って共有フォルダに保存しないよう、" & vbCrLf & _
               "コピー先はローカルフォルダ（例: C:\Data）を指定してください。", _
               vbCritical, "安全確認エラー"
        ws.Range("C5").Select
        Exit Sub
    End If
    If Len(dstBase) < 2 Or Mid(dstBase, 2, 1) <> ":" Then
        MsgBox "コピー先はドライブレター付きのローカルパスを指定してください。" & vbCrLf & _
               "例: C:\Users\ユーザー名\Desktop\Archive", vbCritical, "入力エラー"
        ws.Range("C5").Select
        Exit Sub
    End If

    ' 日付の整合性チェック
    If m_dateFrom > m_dateTo Then
        MsgBox "作成日の From が To より後の日付になっています。", vbCritical, "入力エラー"
        Exit Sub
    End If

    ' コピー元の存在確認
    Set m_fso = CreateObject("Scripting.FileSystemObject")
    If Not m_fso.FolderExists(srcPath) Then
        MsgBox "コピー元フォルダが見つかりません:" & vbCrLf & srcPath, vbCritical, "エラー"
        Exit Sub
    End If

    '----------------------------------------------------------------------
    ' ファイルスキャン（高速化: Dir()で名前取得 → FSO で作成日チェック）
    '----------------------------------------------------------------------
    Set m_copyList = New Collection
    m_totalScanned = 0
    m_excludedFileCount = 0

    Application.StatusBar = "ファイルスキャン中... (ネットワークフォルダの場合、時間がかかることがあります)"
    DoEvents

    Dim startTime As Double: startTime = Timer

    ScanFolder srcPath, recurse

    Dim elapsed As Double: elapsed = Timer - startTime
    Application.StatusBar = False

    '----------------------------------------------------------------------
    ' スキャン結果の確認
    '----------------------------------------------------------------------
    If m_copyList.Count = 0 Then
        MsgBox "条件に一致するファイルが見つかりませんでした。" & vbCrLf & vbCrLf & _
               "スキャンファイル数: " & m_totalScanned & vbCrLf & _
               "スキャン時間: " & Format(elapsed, "0.0") & " 秒" & vbCrLf & vbCrLf & _
               "設定を確認してください:" & vbCrLf & _
               "  - ファイルパターン: " & m_fileExt & vbCrLf & _
               "  - 作成日範囲: " & Format(m_dateFrom, "yyyy/mm/dd") & " ～ " & Format(m_dateTo, "yyyy/mm/dd"), _
               vbInformation, "結果"
        Exit Sub
    End If

    Dim dstPath As String: dstPath = dstBase & "\" & dateFolder

    '----------------------------------------------------------------------
    ' 確認ダイアログ（ファイル一覧表示）
    '----------------------------------------------------------------------
    Dim msg As String
    msg = "以下の条件でコピーを実行します。よろしいですか？" & vbCrLf & vbCrLf
    msg = msg & "【コピー元】" & vbCrLf & "  " & srcPath & vbCrLf
    msg = msg & "【コピー先】" & vbCrLf & "  " & dstPath & vbCrLf
    msg = msg & "【対象】 " & m_copyList.Count & " 件 （スキャン: " & m_totalScanned & " 件 / " & Format(elapsed, "0.0") & "秒）" & vbCrLf
    msg = msg & "【作成日】 " & Format(m_dateFrom, "yyyy/mm/dd") & " ～ " & Format(m_dateTo, "yyyy/mm/dd") & vbCrLf
    If m_excludeCount > 0 Then
        msg = msg & "【除外ファイル】 " & m_excludedFileCount & " 件除外済 (パターン: "
        Dim p As Long
        For p = 0 To m_excludeCount - 1
            If p > 0 Then msg = msg & ", "
            msg = msg & m_excludePatterns(p)
        Next p
        msg = msg & ")" & vbCrLf
    End If
    msg = msg & vbCrLf & "--- 対象ファイル ---" & vbCrLf

    Dim i As Long
    Dim maxShow As Long: maxShow = 25
    For i = 1 To WorksheetFunction.Min(m_copyList.Count, maxShow)
        msg = msg & "  " & m_fso.GetFileName(CStr(m_copyList(i))) & vbCrLf
    Next i
    If m_copyList.Count > maxShow Then
        msg = msg & "  ... 他 " & (m_copyList.Count - maxShow) & " ファイル" & vbCrLf
    End If

    If MsgBox(msg, vbYesNo + vbQuestion + vbDefaultButton2, "コピー実行確認") <> vbYes Then
        MsgBox "キャンセルしました。", vbInformation, "中断"
        Exit Sub
    End If

    '----------------------------------------------------------------------
    ' コピー実行
    '----------------------------------------------------------------------
    ' コピー先フォルダ作成
    If Not m_fso.FolderExists(dstPath) Then
        CreateFolderRecursive dstPath
    End If

    Dim copied As Long: copied = 0
    Dim failed As Long: failed = 0
    Dim logData As Collection
    Set logData = New Collection

    For i = 1 To m_copyList.Count
        Dim srcFile As String: srcFile = CStr(m_copyList(i))
        Dim fileName As String: fileName = m_fso.GetFileName(srcFile)
        Dim dstFile As String: dstFile = dstPath & "\" & fileName

        Application.StatusBar = "コピー中... (" & i & "/" & m_copyList.Count & ") " & fileName
        DoEvents

        On Error Resume Next
        m_fso.CopyFile srcFile, dstFile, True
        If Err.Number = 0 Then
            copied = copied + 1
            logData.Add Array(Format(Now, "yyyy/mm/dd hh:nn:ss"), "OK", fileName, srcFile, "")
        Else
            failed = failed + 1
            logData.Add Array(Format(Now, "yyyy/mm/dd hh:nn:ss"), "NG", fileName, srcFile, Err.Description)
            Err.Clear
        End If
        On Error GoTo 0
    Next i

    Application.StatusBar = False

    '----------------------------------------------------------------------
    ' ログ書込
    '----------------------------------------------------------------------
    WriteLog ws, logData, srcPath, dstPath

    '----------------------------------------------------------------------
    ' 完了メッセージ
    '----------------------------------------------------------------------
    Dim icon As VbMsgBoxStyle
    icon = IIf(failed > 0, vbExclamation, vbInformation)

    Dim doneMsg As String
    doneMsg = "コピー完了！" & vbCrLf & vbCrLf & _
              "成功: " & copied & " ファイル" & vbCrLf & _
              "失敗: " & failed & " ファイル" & vbCrLf & vbCrLf & _
              "コピー先: " & dstPath & vbCrLf & vbCrLf & _
              "コピー先フォルダを開きますか？"

    If MsgBox(doneMsg, vbYesNo + icon, "処理完了") = vbYes Then
        Shell "explorer.exe """ & dstPath & """", vbNormalFocus
    End If

    Set m_fso = Nothing
    Set m_copyList = Nothing

End Sub

'==============================================================================
' フォルダスキャン（再帰対応）
' Dir() でファイル名を一括取得し、FSO.GetFile で作成日チェック
' ※ Dir() はネストできないため、ファイル名→サブフォルダ名の順に収集してから処理
'==============================================================================
Private Sub ScanFolder(ByVal folderPath As String, ByVal recurse As Boolean)

    '--- ステップ1: Dir() でファイル名を高速収集 ---
    Dim fileNames As Collection
    Set fileNames = New Collection

    On Error Resume Next
    Dim fn As String
    fn = Dir(folderPath & "\" & m_fileExt)
    If Err.Number <> 0 Then
        Err.Clear
        On Error GoTo 0
        Exit Sub
    End If
    On Error GoTo 0

    Do While fn <> ""
        fileNames.Add fn
        fn = Dir()
    Loop

    '--- ステップ2: ファイル名除外 → 作成日でフィルタ ---
    Dim i As Long
    Dim dateTo_end As Date
    dateTo_end = DateAdd("d", 1, m_dateTo)  ' To の日も含む（翌日未満で判定）

    For i = 1 To fileNames.Count
        m_totalScanned = m_totalScanned + 1

        ' ファイル名が除外パターンに一致 → スキップ
        If IsExcludedFile(CStr(fileNames(i))) Then
            m_excludedFileCount = m_excludedFileCount + 1
            GoTo NextFile
        End If

        Dim fullPath As String
        fullPath = folderPath & "\" & fileNames(i)

        On Error Resume Next
        Dim f As Object
        Set f = m_fso.GetFile(fullPath)
        If Err.Number = 0 Then
            Dim createdDate As Date
            createdDate = f.DateCreated
            If Err.Number = 0 Then
                If createdDate >= m_dateFrom And createdDate < dateTo_end Then
                    m_copyList.Add fullPath
                End If
            End If
        End If
        Err.Clear
        On Error GoTo 0
        Set f = Nothing

NextFile:
        ' 進捗表示（50件ごと）
        If m_totalScanned Mod 50 = 0 Then
            Application.StatusBar = "スキャン中... " & m_totalScanned & " ファイル処理 / " & m_copyList.Count & " 件該当"
            DoEvents
        End If
    Next i

    '--- ステップ3: サブフォルダ収集（再帰する場合のみ） ---
    If recurse Then
        Dim subFolders As Collection
        Set subFolders = New Collection

        ' FSO経由でサブフォルダを取得（Dir()より確実）
        On Error Resume Next
        Dim parentFolder As Object
        Set parentFolder = m_fso.GetFolder(folderPath)
        If Err.Number <> 0 Then
            Err.Clear
            On Error GoTo 0
            Exit Sub
        End If
        On Error GoTo 0

        Dim subFolder As Object
        For Each subFolder In parentFolder.SubFolders
            subFolders.Add subFolder.Name
        Next subFolder
        Set parentFolder = Nothing

        '--- ステップ4: サブフォルダを再帰処理 ---
        For i = 1 To subFolders.Count
            ScanFolder folderPath & "\" & subFolders(i), True
        Next i
    End If

End Sub

'==============================================================================
' 除外ファイル判定（Like演算子 / Option Compare Text で大文字小文字区別なし）
' ファイル名（拡張子含む）に対してパターンマッチ
'==============================================================================
Private Function IsExcludedFile(ByVal fileName As String) As Boolean
    Dim i As Long
    For i = 0 To m_excludeCount - 1
        If fileName Like m_excludePatterns(i) Then
            IsExcludedFile = True
            Exit Function
        End If
    Next i
    IsExcludedFile = False
End Function

'==============================================================================
' フォルダ再帰作成
'==============================================================================
Private Sub CreateFolderRecursive(ByVal path As String)
    If m_fso.FolderExists(path) Then Exit Sub

    Dim parent As String
    parent = m_fso.GetParentFolderName(path)
    If Not m_fso.FolderExists(parent) Then
        CreateFolderRecursive parent
    End If

    m_fso.CreateFolder path
End Sub

'==============================================================================
' ログ書込（「ログ」シートに追記）
'==============================================================================
Private Sub WriteLog(ByVal wsSetting As Worksheet, ByVal logData As Collection, _
                     ByVal srcPath As String, ByVal dstPath As String)

    Dim wsLog As Worksheet
    On Error Resume Next
    Set wsLog = ThisWorkbook.Sheets("ログ")
    On Error GoTo 0

    ' ログシートがなければ作成
    If wsLog Is Nothing Then
        Set wsLog = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsLog.Name = "ログ"
        wsLog.Range("A1").Value = "日時"
        wsLog.Range("B1").Value = "結果"
        wsLog.Range("C1").Value = "ファイル名"
        wsLog.Range("D1").Value = "フルパス"
        wsLog.Range("E1").Value = "備考"
        wsLog.Range("A1:E1").Font.Bold = True
    End If

    ' AutoFilterが有効な場合は解除（書込エラー防止）
    On Error Resume Next
    If wsLog.AutoFilterMode Then wsLog.AutoFilterMode = False
    On Error GoTo 0

    ' 最終行の次から書込
    Dim startRow As Long
    startRow = wsLog.Cells(wsLog.Rows.Count, 1).End(xlUp).Row + 1
    If startRow < 2 Then startRow = 2

    ' 空行を1行挟む（2回目以降の実行時に見やすく）
    If startRow > 2 Then startRow = startRow + 1

    ' 実行情報ヘッダー（先頭に = を使わない → 数式誤認防止）
    wsLog.Cells(startRow, 1).Value = "[実行] " & Format(Now, "yyyy/mm/dd hh:nn:ss")
    wsLog.Cells(startRow, 2).Value = srcPath
    wsLog.Cells(startRow, 3).Value = dstPath
    wsLog.Range(wsLog.Cells(startRow, 1), wsLog.Cells(startRow, 5)).Font.Bold = True
    wsLog.Range(wsLog.Cells(startRow, 1), wsLog.Cells(startRow, 5)).Interior.Color = RGB(230, 230, 230)
    startRow = startRow + 1

    ' 各ファイルのログ
    Dim i As Long
    For i = 1 To logData.Count
        Dim d As Variant: d = logData(i)
        wsLog.Cells(startRow, 1).Value = d(0)  ' 日時
        wsLog.Cells(startRow, 2).Value = d(1)  ' 結果
        wsLog.Cells(startRow, 3).Value = d(2)  ' ファイル名
        wsLog.Cells(startRow, 4).Value = d(3)  ' フルパス
        wsLog.Cells(startRow, 5).Value = d(4)  ' 備考

        ' NG の場合は赤文字
        If d(1) = "NG" Then
            wsLog.Range(wsLog.Cells(startRow, 1), wsLog.Cells(startRow, 5)).Font.Color = RGB(204, 0, 0)
        End If

        startRow = startRow + 1
    Next i

    ' 列幅調整
    wsLog.Columns("A:E").AutoFit

    ' 設定シートに戻る
    wsSetting.Activate

End Sub

'==============================================================================
' ユーティリティ: 日付フォルダ名を今日の日付に更新
'==============================================================================
Public Sub 日付フォルダ名を今日に更新()
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("設定")
    On Error GoTo 0
    If ws Is Nothing Then Exit Sub

    ws.Range("C6").Value = Format(Date, "yyyy\_mmdd")
    MsgBox "日付フォルダ名を「" & ws.Range("C6").Value & "」に更新しました。", vbInformation, "更新完了"
End Sub

'==============================================================================
' ユーティリティ: コピー先フォルダを開く
'==============================================================================
Public Sub コピー先フォルダを開く()
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("設定")
    On Error GoTo 0
    If ws Is Nothing Then Exit Sub

    Dim dstPath As String
    dstPath = Trim(CStr(ws.Range("C5").Value)) & "\" & Trim(CStr(ws.Range("C6").Value))

    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")

    If fso.FolderExists(dstPath) Then
        Shell "explorer.exe """ & dstPath & """", vbNormalFocus
    Else
        MsgBox "フォルダが見つかりません:" & vbCrLf & dstPath, vbExclamation, "エラー"
    End If
End Sub


let
    設定 = Excel.CurrentWorkbook(){[Name="tbl_マスター設定"]}[Content],
    サイトURL = 設定{0}[サイトURL],

    Source = SharePoint.Files(サイトURL, [ApiVersion = 15]),
    必要列だけ = Table.SelectColumns(Source, {"Name", "Folder Path"})
in
    必要列だけ
Excelリストコピーツールダウンロード
Attribute VB_Name = "modExcelListCopy"
'==============================================================================
' Excel一覧コピーツール（リスト指定）
'
' 機能: 設定シートのファイルリストに基づき、コピー元フォルダから
'       該当ファイルをローカルフォルダへコピーする。
'
' 特徴: - ファイル名リストで指定（大文字小文字区別なし）
'        - 拡張子省略時は .xlsx → .xls → .xlsm の順で自動検索
'        - コピー先はローカルフォルダのみ（安全対策）
'        - 既存ファイルは上書きしない（事故防止）
'        - 実行後コピー先フォルダへのハイパーリンクを設定
'        - D列に説明メモを自由記入可能（コピー後チェックリストとして活用）
'==============================================================================
Option Explicit
Option Compare Text  ' 大文字小文字を区別しない

Private Const LIST_START_ROW As Long = 11   ' ファイルリスト開始行
Private Const COL_FILENAME As Long = 3      ' C列: ファイル名
Private Const COL_MEMO As Long = 4          ' D列: 説明・メモ
Private Const COL_RESULT As Long = 5        ' E列: 結果

' Excel系拡張子（拡張子省略時の検索順）
Private Const EXT_LIST As String = ".xlsx,.xls,.xlsm"

Private m_fso As Object

'==============================================================================
' メインマクロ: Excelリストコピー実行
'==============================================================================
Public Sub Excelリストコピー実行()

    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("設定")
    On Error GoTo 0
    If ws Is Nothing Then
        MsgBox "「設定」シートが見つかりません。", vbCritical, "エラー"
        Exit Sub
    End If

    '----------------------------------------------------------------------
    ' 設定値の読込
    '----------------------------------------------------------------------
    Dim srcPath As String:     srcPath = Trim(CStr(ws.Range("C4").Value))
    Dim dstBase As String:     dstBase = Trim(CStr(ws.Range("C5").Value))
    Dim subFolderName As String: subFolderName = Trim(CStr(ws.Range("C6").Value))

    ' パス末尾の \ を除去
    If Len(srcPath) > 0 And Right(srcPath, 1) = "\" Then srcPath = Left(srcPath, Len(srcPath) - 1)
    If Len(dstBase) > 0 And Right(dstBase, 1) = "\" Then dstBase = Left(dstBase, Len(dstBase) - 1)

    '----------------------------------------------------------------------
    ' ファイルリストの読込
    '----------------------------------------------------------------------
    Dim fileList As Collection  ' 各要素: Array(行番号, ファイル名)
    Set fileList = New Collection

    Dim r As Long: r = LIST_START_ROW
    Do While r <= 1000
        Dim cellVal As String
        cellVal = Trim(CStr(ws.Cells(r, COL_FILENAME).Value))
        If cellVal = "" Then Exit Do
        fileList.Add Array(r, cellVal)
        r = r + 1
    Loop

    '----------------------------------------------------------------------
    ' バリデーション
    '----------------------------------------------------------------------
    If srcPath = "" Then
        MsgBox "コピー元フォルダが未入力です。", vbCritical, "入力エラー"
        ws.Range("C4").Select: Exit Sub
    End If
    If dstBase = "" Then
        MsgBox "コピー先ベースフォルダが未入力です。", vbCritical, "入力エラー"
        ws.Range("C5").Select: Exit Sub
    End If
    If subFolderName = "" Then
        MsgBox "サブフォルダ名が未入力です。", vbCritical, "入力エラー"
        ws.Range("C6").Select: Exit Sub
    End If

    ' コピー先がローカルか確認
    If Left(dstBase, 2) = "\\" Then
        MsgBox "【安全確認エラー】" & vbCrLf & vbCrLf & _
               "コピー先にネットワークパス（\\...）が指定されています。" & vbCrLf & _
               "誤って共有フォルダに保存しないよう、" & vbCrLf & _
               "コピー先はローカルフォルダ（例: C:\Data）を指定してください。", _
               vbCritical, "安全確認エラー"
        ws.Range("C5").Select
        Exit Sub
    End If
    If Len(dstBase) < 2 Or Mid(dstBase, 2, 1) <> ":" Then
        MsgBox "コピー先はドライブレター付きのローカルパスを指定してください。" & vbCrLf & _
               "例: C:\Users\ユーザー名\Desktop\Archive", vbCritical, "入力エラー"
        ws.Range("C5").Select
        Exit Sub
    End If

    Set m_fso = CreateObject("Scripting.FileSystemObject")

    ' コピー元の存在確認
    If Not m_fso.FolderExists(srcPath) Then
        MsgBox "コピー元フォルダが見つかりません:" & vbCrLf & srcPath, vbCritical, "エラー"
        Exit Sub
    End If

    ' リストが空
    If fileList.Count = 0 Then
        MsgBox "コピー対象のファイル名が1件も入力されていません。" & vbCrLf & _
               "C11セル以降にファイル名を入力してください。", vbExclamation, "入力エラー"
        ws.Range("C11").Select
        Exit Sub
    End If

    '----------------------------------------------------------------------
    ' ファイル存在チェック（リスト照合）
    '----------------------------------------------------------------------
    Application.StatusBar = "ファイル検索中..."
    DoEvents

    Dim foundList As Collection   ' Array(行番号, 入力名, 実ファイルパス)
    Set foundList = New Collection
    Dim notFoundList As Collection ' Array(行番号, 入力名)
    Set notFoundList = New Collection

    Dim i As Long
    For i = 1 To fileList.Count
        Dim rowNum As Long:    rowNum = fileList(i)(0)
        Dim inputName As String: inputName = fileList(i)(1)

        Dim resolvedPath As String
        resolvedPath = FindFileInFolder(srcPath, inputName)

        If resolvedPath <> "" Then
            foundList.Add Array(rowNum, inputName, resolvedPath)
        Else
            notFoundList.Add Array(rowNum, inputName)
        End If
    Next i

    Application.StatusBar = False

    '----------------------------------------------------------------------
    ' 確認ダイアログ
    '----------------------------------------------------------------------
    Dim dstPath As String: dstPath = dstBase & "\" & subFolderName

    Dim msg As String
    msg = "以下の条件でコピーを実行します。よろしいですか？" & vbCrLf & vbCrLf
    msg = msg & "【コピー元】" & vbCrLf & "  " & srcPath & vbCrLf
    msg = msg & "【コピー先】" & vbCrLf & "  " & dstPath & vbCrLf
    msg = msg & "【リスト件数】 " & fileList.Count & " 件" & vbCrLf
    msg = msg & "【見つかった】 " & foundList.Count & " 件" & vbCrLf
    msg = msg & "【上書き防止】 コピー先に同名ファイルがあればスキップ" & vbCrLf

    If notFoundList.Count > 0 Then
        msg = msg & "【見つからない】 " & notFoundList.Count & " 件" & vbCrLf
        msg = msg & vbCrLf & "--- 見つからないファイル ---" & vbCrLf
        Dim n As Long
        For n = 1 To notFoundList.Count
            msg = msg & "  x " & notFoundList(n)(1) & vbCrLf
        Next n
    End If

    If foundList.Count > 0 Then
        msg = msg & vbCrLf & "--- コピー対象 ---" & vbCrLf
        Dim maxShow As Long: maxShow = 20
        For i = 1 To WorksheetFunction.Min(foundList.Count, maxShow)
            msg = msg & "  " & m_fso.GetFileName(CStr(foundList(i)(2))) & vbCrLf
        Next i
        If foundList.Count > maxShow Then
            msg = msg & "  ... 他 " & (foundList.Count - maxShow) & " ファイル" & vbCrLf
        End If
    End If

    If foundList.Count = 0 Then
        MsgBox msg & vbCrLf & "コピー可能なファイルがありません。", vbExclamation, "結果"
        WriteResultColumn ws, notFoundList, foundList, False
        Exit Sub
    End If

    If MsgBox(msg, vbYesNo + vbQuestion + vbDefaultButton2, "コピー実行確認") <> vbYes Then
        MsgBox "キャンセルしました。", vbInformation, "中断"
        Exit Sub
    End If

    '----------------------------------------------------------------------
    ' コピー先フォルダの存在確認
    '----------------------------------------------------------------------
    If m_fso.FolderExists(dstPath) Then
        ' 既存フォルダの場合 → 確認（ファイル上書きはしないが念のため）
        If MsgBox("コピー先フォルダが既に存在します。" & vbCrLf & vbCrLf & _
                  dstPath & vbCrLf & vbCrLf & _
                  "このフォルダにコピーしてよろしいですか？" & vbCrLf & _
                  "（同名ファイルがある場合はスキップされます）", _
                  vbYesNo + vbQuestion + vbDefaultButton2, "フォルダ存在確認") <> vbYes Then
            MsgBox "キャンセルしました。", vbInformation, "中断"
            Exit Sub
        End If
    Else
        CreateFolderRecursive dstPath
    End If

    Dim copied As Long: copied = 0
    Dim failed As Long: failed = 0
    Dim skipped As Long: skipped = 0
    Dim logData As Collection
    Set logData = New Collection

    For i = 1 To foundList.Count
        Dim srcFile As String: srcFile = CStr(foundList(i)(2))
        Dim fileName As String: fileName = m_fso.GetFileName(srcFile)
        Dim dstFile As String: dstFile = dstPath & "\" & fileName

        Application.StatusBar = "コピー中... (" & i & "/" & foundList.Count & ") " & fileName
        DoEvents

        ' 上書き防止: 既存ファイルがあればスキップ
        If m_fso.FileExists(dstFile) Then
            skipped = skipped + 1
            foundList(i) = Array(foundList(i)(0), foundList(i)(1), srcFile, "スキップ（既存）")
            logData.Add Array(Format(Now, "yyyy/mm/dd hh:nn:ss"), "SKIP", fileName, srcFile, "コピー先に同名ファイルが既に存在")
            GoTo NextCopy
        End If

        On Error Resume Next
        m_fso.CopyFile srcFile, dstFile, False  ' False = 上書きしない
        If Err.Number = 0 Then
            copied = copied + 1
            foundList(i) = Array(foundList(i)(0), foundList(i)(1), srcFile, "OK")
            logData.Add Array(Format(Now, "yyyy/mm/dd hh:nn:ss"), "OK", fileName, srcFile, "")
        Else
            failed = failed + 1
            foundList(i) = Array(foundList(i)(0), foundList(i)(1), srcFile, "NG: " & Err.Description)
            logData.Add Array(Format(Now, "yyyy/mm/dd hh:nn:ss"), "NG", fileName, srcFile, Err.Description)
            Err.Clear
        End If
        On Error GoTo 0

NextCopy:
    Next i

    Application.StatusBar = False

    '----------------------------------------------------------------------
    ' 結果をE列に書込
    '----------------------------------------------------------------------
    WriteResultColumn ws, notFoundList, foundList, True, dstPath

    '----------------------------------------------------------------------
    ' コピー先フォルダへのハイパーリンクをC7に設定
    '----------------------------------------------------------------------
    On Error Resume Next
    ws.Hyperlinks.Add _
        Anchor:=ws.Range("C7"), _
        Address:=dstPath, _
        TextToDisplay:=dstPath
    ws.Range("C7").Font.Color = RGB(0, 0, 200)
    ws.Range("C7").Font.Underline = xlUnderlineStyleSingle
    On Error GoTo 0

    '----------------------------------------------------------------------
    ' ログ書込
    '----------------------------------------------------------------------
    WriteLog ws, logData, srcPath, dstPath

    '----------------------------------------------------------------------
    ' 完了メッセージ
    '----------------------------------------------------------------------
    Dim icon As VbMsgBoxStyle
    icon = IIf(failed > 0 Or notFoundList.Count > 0, vbExclamation, vbInformation)

    Dim doneMsg As String
    doneMsg = "コピー完了！" & vbCrLf & vbCrLf & _
              "成功: " & copied & " ファイル" & vbCrLf & _
              "スキップ（既存）: " & skipped & " ファイル" & vbCrLf & _
              "失敗: " & failed & " ファイル" & vbCrLf & _
              "未発見: " & notFoundList.Count & " ファイル" & vbCrLf & vbCrLf & _
              "コピー先: " & dstPath & vbCrLf & vbCrLf & _
              "コピー先フォルダを開きますか？"

    If MsgBox(doneMsg, vbYesNo + icon, "処理完了") = vbYes Then
        Shell "explorer.exe """ & dstPath & """", vbNormalFocus
    End If

    Set m_fso = Nothing

End Sub

'==============================================================================
' ファイル検索（大文字小文字区別なし / 拡張子省略対応）
' 1) 入力名そのままで Dir() → 見つかればそのパスを返す
' 2) 拡張子がない場合、.xlsx → .xls → .xlsm の順で検索
'==============================================================================
Private Function FindFileInFolder(ByVal folderPath As String, ByVal inputName As String) As String
    FindFileInFolder = ""

    Dim result As String
    On Error Resume Next
    result = Dir(folderPath & "\" & inputName)
    On Error GoTo 0

    If result <> "" Then
        FindFileInFolder = folderPath & "\" & result
        Exit Function
    End If

    ' 拡張子がついていない場合、候補を順に試す
    If InStr(inputName, ".") = 0 Then
        Dim exts() As String
        exts = Split(EXT_LIST, ",")
        Dim e As Long
        For e = 0 To UBound(exts)
            On Error Resume Next
            result = Dir(folderPath & "\" & inputName & exts(e))
            On Error GoTo 0
            If result <> "" Then
                FindFileInFolder = folderPath & "\" & result
                Exit Function
            End If
        Next e
    End If

End Function

'==============================================================================
' 結果をE列に書込（D列の説明メモは触らない）
' OK / スキップ → コピー先ファイルへのハイパーリンク付き
'==============================================================================
Private Sub WriteResultColumn(ByVal ws As Worksheet, _
                              ByVal notFoundList As Collection, _
                              ByVal foundList As Collection, _
                              ByVal afterCopy As Boolean, _
                              Optional ByVal dstPath As String = "")

    ' 結果列（E列）のみクリア（ハイパーリンクも削除）
    Dim r As Long
    For r = LIST_START_ROW To LIST_START_ROW + 100
        On Error Resume Next
        ws.Cells(r, COL_RESULT).Hyperlinks.Delete
        On Error GoTo 0
        ws.Cells(r, COL_RESULT).Value = ""
        ws.Cells(r, COL_RESULT).Font.Color = RGB(0, 0, 0)
        ws.Cells(r, COL_RESULT).Font.Underline = xlUnderlineStyleNone
    Next r

    ' 見つからないファイル
    Dim i As Long
    For i = 1 To notFoundList.Count
        Dim nfRow As Long: nfRow = notFoundList(i)(0)
        ws.Cells(nfRow, COL_RESULT).Value = "見つかりません"
        ws.Cells(nfRow, COL_RESULT).Font.Color = RGB(204, 0, 0)
    Next i

    ' コピー結果
    If afterCopy Then
        For i = 1 To foundList.Count
            Dim fRow As Long: fRow = foundList(i)(0)
            If UBound(foundList(i)) >= 3 Then
                Dim res As String: res = CStr(foundList(i)(3))
                Dim fName As String: fName = ""

                ' ファイル名を取得（リンク用）
                If UBound(foundList(i)) >= 2 Then
                    On Error Resume Next
                    fName = m_fso.GetFileName(CStr(foundList(i)(2)))
                    On Error GoTo 0
                End If

                If res = "OK" And dstPath <> "" And fName <> "" Then
                    ' コピー成功 → コピー先ファイルへの直リンク
                    Dim filePath As String: filePath = dstPath & "\" & fName
                    On Error Resume Next
                    ws.Hyperlinks.Add _
                        Anchor:=ws.Cells(fRow, COL_RESULT), _
                        Address:=filePath, _
                        TextToDisplay:="OK - 開く"
                    ws.Cells(fRow, COL_RESULT).Font.Color = RGB(0, 128, 0)
                    On Error GoTo 0

                ElseIf InStr(res, "スキップ") > 0 And dstPath <> "" And fName <> "" Then
                    ' スキップ（既存） → 既存ファイルへの直リンク
                    Dim existPath As String: existPath = dstPath & "\" & fName
                    On Error Resume Next
                    ws.Hyperlinks.Add _
                        Anchor:=ws.Cells(fRow, COL_RESULT), _
                        Address:=existPath, _
                        TextToDisplay:="スキップ(既存) - 開く"
                    ws.Cells(fRow, COL_RESULT).Font.Color = RGB(180, 130, 0)
                    On Error GoTo 0

                Else
                    ' NG等
                    ws.Cells(fRow, COL_RESULT).Value = res
                    ws.Cells(fRow, COL_RESULT).Font.Color = RGB(204, 0, 0)
                End If
            End If
        Next i
    Else
        For i = 1 To foundList.Count
            Dim fRow2 As Long: fRow2 = foundList(i)(0)
            ws.Cells(fRow2, COL_RESULT).Value = "検出済（未コピー）"
            ws.Cells(fRow2, COL_RESULT).Font.Color = RGB(100, 100, 100)
        Next i
    End If

End Sub

'==============================================================================
' フォルダ再帰作成
'==============================================================================
Private Sub CreateFolderRecursive(ByVal path As String)
    If m_fso.FolderExists(path) Then Exit Sub
    Dim parent As String
    parent = m_fso.GetParentFolderName(path)
    If Not m_fso.FolderExists(parent) Then
        CreateFolderRecursive parent
    End If
    m_fso.CreateFolder path
End Sub

'==============================================================================
' ログ書込
'==============================================================================
Private Sub WriteLog(ByVal wsSetting As Worksheet, ByVal logData As Collection, _
                     ByVal srcPath As String, ByVal dstPath As String)

    Dim wsLog As Worksheet
    On Error Resume Next
    Set wsLog = ThisWorkbook.Sheets("ログ")
    On Error GoTo 0

    If wsLog Is Nothing Then
        Set wsLog = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(ThisWorkbook.Sheets.Count))
        wsLog.Name = "ログ"
        wsLog.Range("A1").Value = "日時"
        wsLog.Range("B1").Value = "結果"
        wsLog.Range("C1").Value = "ファイル名"
        wsLog.Range("D1").Value = "フルパス"
        wsLog.Range("E1").Value = "備考"
        wsLog.Range("A1:E1").Font.Bold = True
    End If

    On Error Resume Next
    If wsLog.AutoFilterMode Then wsLog.AutoFilterMode = False
    On Error GoTo 0

    Dim startRow As Long
    startRow = wsLog.Cells(wsLog.Rows.Count, 1).End(xlUp).Row + 1
    If startRow < 2 Then startRow = 2
    If startRow > 2 Then startRow = startRow + 1

    wsLog.Cells(startRow, 1).Value = "[実行] " & Format(Now, "yyyy/mm/dd hh:nn:ss")
    wsLog.Cells(startRow, 2).Value = srcPath
    wsLog.Cells(startRow, 3).Value = dstPath
    wsLog.Range(wsLog.Cells(startRow, 1), wsLog.Cells(startRow, 5)).Font.Bold = True
    wsLog.Range(wsLog.Cells(startRow, 1), wsLog.Cells(startRow, 5)).Interior.Color = RGB(230, 230, 230)
    startRow = startRow + 1

    Dim i As Long
    For i = 1 To logData.Count
        Dim d As Variant: d = logData(i)
        wsLog.Cells(startRow, 1).Value = d(0)
        wsLog.Cells(startRow, 2).Value = d(1)
        wsLog.Cells(startRow, 3).Value = d(2)
        wsLog.Cells(startRow, 4).Value = d(3)
        wsLog.Cells(startRow, 5).Value = d(4)
        If d(1) = "NG" Then
            wsLog.Range(wsLog.Cells(startRow, 1), wsLog.Cells(startRow, 5)).Font.Color = RGB(204, 0, 0)
        ElseIf d(1) = "SKIP" Then
            wsLog.Range(wsLog.Cells(startRow, 1), wsLog.Cells(startRow, 5)).Font.Color = RGB(180, 130, 0)
        End If
        startRow = startRow + 1
    Next i

    wsLog.Columns("A:E").AutoFit
    wsSetting.Activate

End Sub

'==============================================================================
' ユーティリティ: コピー先フォルダを開く
'==============================================================================
Public Sub コピー先フォルダを開く_リスト()
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("設定")
    On Error GoTo 0
    If ws Is Nothing Then Exit Sub
    Dim dstPath As String
    dstPath = Trim(CStr(ws.Range("C5").Value)) & "\" & Trim(CStr(ws.Range("C6").Value))
    Dim fso As Object
    Set fso = CreateObject("Scripting.FileSystemObject")
    If fso.FolderExists(dstPath) Then
        Shell "explorer.exe """ & dstPath & """", vbNormalFocus
    Else
        MsgBox "フォルダが見つかりません:" & vbCrLf & dstPath, vbExclamation, "エラー"
    End If
End Sub

'==============================================================================
' ユーティリティ: 結果列（E列）をクリア
'==============================================================================
Public Sub 結果列クリア()
    Dim ws As Worksheet
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("設定")
    On Error GoTo 0
    If ws Is Nothing Then Exit Sub
    Dim r As Long
    For r = LIST_START_ROW To LIST_START_ROW + 100
        On Error Resume Next
        ws.Cells(r, COL_RESULT).Hyperlinks.Delete
        On Error GoTo 0
        ws.Cells(r, COL_RESULT).Value = ""
        ws.Cells(r, COL_RESULT).Font.Color = RGB(0, 0, 0)
        ws.Cells(r, COL_RESULT).Font.Underline = xlUnderlineStyleNone
    Next r
    MsgBox "結果列をクリアしました。", vbInformation, "完了"
End Sub

let
    実行日時 = DateTime.LocalNow(),

    マスター = Q_SP_マスター,
    追加 = Q_追加統合,

    マージ = Table.NestedJoin(
        追加, {"製造番号"},
        マスター, {"製造番号"},
        "マスター", JoinKind.LeftOuter
    ),

    展開 = Table.ExpandTableColumn(
        マージ,
        "マスター",
        {"納先", "ハード設計要求"},
        {"前回_納先", "前回_要求"}
    ),

    操作列 = Table.AddColumn(
        展開,
        "操作",
        each
            if [前回_納先] = null and [前回_要求] = null then
                "新規追加"
            else if [納先] = [前回_納先] and [ハード設計要求] = [前回_要求] then
                "上書き_変化無し"
            else
                "上書き_変化アリ",
        type text
    ),

    表示列 = Table.SelectColumns(
        操作列,
        {"製造番号", "操作", "読込元ファイル"},
        MissingField.Ignore
    ),

    実行日時追加 = Table.AddColumn(表示列, "実行日時", each 実行日時, type datetime)
in
    実行日時追加
]]> https://manabinotes.com/%e3%80%90vba%e3%80%91%e6%97%a5%e4%bb%98%e3%82%92%e3%82%ad%e3%83%bc%e3%81%ab%e3%81%97%e3%81%9f%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%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 処理の流れ

マクロ 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 やりたかったこと

複数の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 【PAD】重複ありのExcelリストを高速集約！プロセス残留を防ぎ「0行の壁」を突破する決定版フロー https://manabinotes.com/%e9%87%8d%e8%a4%87%e3%81%82%e3%82%8a%e3%81%ae%e3%82%a8%e3%82%af%e3%82%bb%e3%83%ab%e8%be%9e%e6%9b%b8%e3%83%aa%e3%82%b9%e3%83%88%e3%82%92%e9%9b%86%e7%b4%84%e3%81%99%e3%82%8b%e3%83%95%e3%83%ad%e3%83%bc/ https://manabinotes.com/%e9%87%8d%e8%a4%87%e3%81%82%e3%82%8a%e3%81%ae%e3%82%a8%e3%82%af%e3%82%bb%e3%83%ab%e8%be%9e%e6%9b%b8%e3%83%aa%e3%82%b9%e3%83%88%e3%82%92%e9%9b%86%e7%b4%84%e3%81%99%e3%82%8b%e3%83%95%e3%83%ad%e3%83%bc/#respond Thu, 19 Feb 2026 16:49:11 +0000 https://manabinotes.com/?p=130 Power Automate Desktop（PAD）で、同じIDを持つ複数行のデータを1行にまとめたい（グループ化したい）場面は多いですよね。

しかし、いざ作ってみると「Excelが裏で残り続ける」「データテーブルの挙動が謎でエラーが出る」といった壁にぶつかりがちです。

本記事では、実務でそのまま使える「安定性・高速性・保守性」を兼ね備えた集約フローを徹底解説します。

1. 実現したい処理のイメージ

以下のように、左列（ID）が同じデータの右列（値）を、スペース区切りで1行に集約します。

＜集約前＞

＜集約後＞

2. フロー全体の構成

このフローは大きく「エクセルデータの読込」と「データ整形」の2つのブロックで構成されています。

ステップ1：Excelプロセス残留防止

・ Excelインスタン表示をOFF(処理時にエクセル画面表示しない)とし、高速化を図っています。(ただし、クラッシュ時の非表示プロセス残留防止要)

・ 非表示プロセス残留防止のため、ExcelプロセスはBLOCK アクションで囲み、エラー時に確実に「Excelを閉じる」が実行されるようにしています。


ステップ2：データ整形ロジック

・ 「1つ前の行」と比較しながら、新しいデータテーブルを構築していきます。

・ PADのデータテーブルは最後の1行を消すと列情報まで消える「0行の壁問題」があるため、最初から1行目を設定しておくのが安全です。

・ 「全行から検索して結合」という力技を避け、上から順に見ていくだけで集約が終わるアルゴリズムとしています。

・ Excelに空白セルがある場合、そのまま結合すると不要なスペースが重なるため、結合処理の実施条件を「$”’%”%”’（空文字）」としています。

3. コピペ用コード

**REGION エクセルデータの読込
BLOCK Excelプロセス残留防止
ON BLOCK ERROR

END
    Excel.LaunchExcel.LaunchAndOpenUnderExistingProcess Path: $'''C:\\PDF_sakusei\\dwglist.xlsx''' Visible: False ReadOnly: True UseMachineLocale: False Instance=> ExcelInstance
    Excel.ReadFromExcel.ReadAllCells Instance: ExcelInstance GetCellContentsMode: Excel.GetCellContentsMode.TypedValues FirstLineIsHeader: False RangeValue=> ExcelData
    Excel.CloseExcel.Close Instance: ExcelInstance
END
Excel.CloseExcel.Close Instance: ExcelInstance
ON ERROR

END
**ENDREGION
**REGION データ整形
Variables.CreateNewDatatable InputTable: { ^['Column1', 'Column2'], [$'''''', $''''''] } DataTable=> DataTable
SET PrevNumber TO $'''%''%'''
SET CurrentRowIndex TO -1
LOOP FOREACH CurrentItem IN ExcelData
    IF CurrentRowIndex = (-1) THEN
        Variables.ModifyDataTableItem DataTable: DataTable ColumnNameOrIndex: 0 RowIndex: 0 Value: CurrentItem[0]
        Variables.ModifyDataTableItem DataTable: DataTable ColumnNameOrIndex: 1 RowIndex: 0 Value: CurrentItem[1]
        SET CurrentRowIndex TO 0
    ELSE
        IF CurrentItem[0] = PrevNumber THEN
            IF CurrentItem[1] <> $'''$\'\'\'%''%\'\'\'''' THEN
                SET DataTable[CurrentRowIndex][1] TO $'''%DataTable[CurrentRowIndex][1]% %CurrentItem[1]%'''
            END
        ELSE
            Variables.AddRowToDataTable.AppendRowToDataTable DataTable: DataTable RowToAdd: [CurrentItem[0], CurrentItem[1]]
            SET CurrentRowIndex TO CurrentRowIndex + 1
        END
    END
    SET PrevNumber TO CurrentItem[0]
END
**ENDREGION

4. まとめ

このフローのポイントをまとめると以下の通りです。

  • Excelの高速化: インスタンス参照なしとしている。※エラー終了時のプロセス残留防止措置要
  • Excelの残留防止: BLOCK と ON ERROR で確実に閉じる。
  • データテーブル集約の高速化: 全体検索せず「前の行」と比較するロジックを採用。
  • データテーブルの仕様攻略: 最初の空行を「上書き」して列定義を守る。

この構成をテンプレートとして持っておけば、Excelデータの集約作業が劇的に安定・高速化します。ぜひ活用してみてください！

]]> https://manabinotes.com/%e9%87%8d%e8%a4%87%e3%81%82%e3%82%8a%e3%81%ae%e3%82%a8%e3%82%af%e3%82%bb%e3%83%ab%e8%be%9e%e6%9b%b8%e3%83%aa%e3%82%b9%e3%83%88%e3%82%92%e9%9b%86%e7%b4%84%e3%81%99%e3%82%8b%e3%83%95%e3%83%ad%e3%83%bc/feed/ 0 【Linux】絶対パスと相対パス https://manabinotes.com/%e3%80%90linux%e3%80%91%e7%b5%b6%e5%af%be%e3%83%91%e3%82%b9%e3%81%a8%e7%9b%b8%e5%af%be%e3%83%91%e3%82%b9/ https://manabinotes.com/%e3%80%90linux%e3%80%91%e7%b5%b6%e5%af%be%e3%83%91%e3%82%b9%e3%81%a8%e7%9b%b8%e5%af%be%e3%83%91%e3%82%b9/#respond Mon, 20 Feb 2023 16:49:33 +0000 https://manabinotes.com/?p=73

カレントディレクトリ

./

親ディレクトリ

../

ホームディレクトリ

~/
]]> https://manabinotes.com/%e3%80%90linux%e3%80%91%e7%b5%b6%e5%af%be%e3%83%91%e3%82%b9%e3%81%a8%e7%9b%b8%e5%af%be%e3%83%91%e3%82%b9/feed/ 0