処理の流れ
設定シート（Excel）から条件を読み込み → バリデーション → ネットワーク上のフォルダをスキャン → 条件に合うPDFをローカルにコピー → ログ記録、という一連の流れです。
スキャンの仕組み
まず Dir("*.pdf") でファイル名だけを高速に一括取得し、次にファイル名が除外パターン（LL* など）に一致するものをスキップ。残ったファイルだけ FSO.GetFile で作成日を取得して日付範囲内かチェックします。除外パターンに一致したファイルはFSO呼び出し自体をスキップするので、ネットワーク越しのアクセスを減らせます。
安全対策
コピー先が \\ で始まるネットワークパスだとエラーで停止（共有フォルダへの誤コピー防止）。実行前に対象ファイル一覧・件数・除外件数を確認ダイアログで表示し、デフォルトが「いいえ」なので手が滑っても実行されません。
設定シートで指定できる項目
コピー元パス、コピー先ベースパス、日付フォルダ名（2026_0302 等）、ファイルパターン、作成日 From/To、サブフォルダ検索（デフォルトOFF）、除外ファイル名パターン（複数指定可）の7項目です。
ログ
実行ごとに「ログ」シートへ追記され、各ファイルの成功/失敗とエラー内容が記録されます。
'==============================================================================
' 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
必要列だけ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
実行日時追加
コメント