VBA | まなびの書 https://manabinotes.com Wed, 11 Mar 2026 22:26:18 +0000 ja hourly 1 https://wordpress.org/?v=6.9.4 【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
  1. 全体フロー
  2. 初回セットアップ（1回だけ）
  3. 毎回の操作
    1. Step 1: Excel でデータ入力
    2. Step 2: 設定を調整（任意）
    3. Step 3: マクロ実行
    4. Step 4: PDF-XChange Editor で貼り付け
  4. 技術ポイント
    1. VBAマクロの役割
    2. 生成される JavaScript の処理内容
    3. 必要な環境

全体フロー

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/64-2/ https://manabinotes.com/64-2/#respond Tue, 07 Feb 2023 22:45:21 +0000 https://manabinotes.com/?p=64 コード

]]> https://manabinotes.com/64-2/feed/ 0 【VBA】 2つのEXCELまたはCSVファイルを比較する https://manabinotes.com/%e3%80%90vba%e3%80%91-2%e3%81%a4%e3%81%aeexcel%e3%81%be%e3%81%9f%e3%81%af/ https://manabinotes.com/%e3%80%90vba%e3%80%91-2%e3%81%a4%e3%81%aeexcel%e3%81%be%e3%81%9f%e3%81%af/#respond Tue, 07 Feb 2023 14:56:42 +0000 https://manabinotes.com/?p=38
  1. 経緯
  2. 機能
  3. コード

経緯

職場で山のようなエクセルファイル同士の突き合わせチェックが必要でしたが、
比較ソフトのDL・インストールができない堅い環境だったので、
これまでしかなたくEXCEL内蔵のInquire機能か数式を使って泥臭く作業をしていました。

しかし、エクセルVBAの使用は可能であるため、
今回VBAを利用して自動的にファイルを比較する簡単なコードを組んでみました。

機能

業務で必要な下記の機能を実装します。

  • 2つのファイル(excel, csv)をエクスプローラーから開く。
  • それらのを比較し共通点が多い行を自動で判別して横に並べる。
  • 各行の全セルの差分を出す。

コード

]]> https://manabinotes.com/%e3%80%90vba%e3%80%91-2%e3%81%a4%e3%81%aeexcel%e3%81%be%e3%81%9f%e3%81%af/feed/ 0