エクセルのマクロについて教えてください 物件ごとのフォルダを作成してます そのフォルダ内にサブフォル

エクセルのマクロについて教えてください
物件ごとのフォルダを作成してます
そのフォルダ内にサブフォルダを作成して
審査　検査　の2つのフォルダがあり
審査フォルダ内にマクロを設定しているファイルがあります
マクロを実行して審査フォルダの中にあるファイル
〇〇新築（交付用）.pdfを　検査フォルダ内にコピー出来る方法を教えてください
以前教えていただき
マクロ
Sub ファイルコピー()
Dim myPath(2) As String
Dim FileName As String
' ファイル元保管場所
myPath(1) = ThisWorkbook.Path & "\審査\"
' ファイル貼り付け先
myPath(2) = ThisWorkbook.Path & "\審査\"
FileName = Dir(myPath(1) & "*（交付用）.pdf")
Do While FileName <> ""
FileCopy myPath(1) & FileName, myPath(2) & FileName
FileName = Dir
Loop
End Sub
を設定しましたが
このマクロだと　審査　検査　があるフォルダ内にマクロを設定したファイルが無ければマクロが実行できません
先に書きましたように
物件フォルダ内に審査フォルダ　検査フォルダがあり　審査フォルダ内にマクロファイルがある場合にマクロを実行できる方法をを教えてください
詳しくコードを教えてください
よろしくお願いします

No.1 ベストアンサー 回答者： Qchan1962 回答日時： 2023/07/02 19:59

Sub ファイルコピー()

Dim myPath As Variant
Dim fPath As String, fName As String
fPath = ThisWorkbook.Path
fPath = Left(fPath, InStrRev(fPath, "\") - 1)
myPath = folder_acquisition(fPath)
fName = Dir(myPath(1) & "*（交付用）.pdf")
Do While fName <> ""
FileCopy myPath(1) & fName, myPath(2) & fName
fName = Dir
Loop
End Sub

Function folder_acquisition(fPath As String) As Variant()
Dim fso As Object, f As Object
Dim n As Integer
Dim myPath(2) As Variant
Set fso = CreateObject("Scripting.FileSystemObject")
With fso
For Each f In .GetFolder(fPath).SubFolders
Select Case Mid(f.Path, InStrRev(f.Path, "\") + 1)
Case "審査"
myPath(1) = f.Path & "\"
n = n + 1
Case "検査"
myPath(2) = f.Path & "\"
n = n + 1
End Select
If n = 2 Then Exit For
Next f
End With
Set fso = Nothing
folder_acquisition = myPath()
End Function

この回答へのお礼

いつも回答ありがとうございます
早速試してみます
後ほどご連絡させていただきます

お礼日時：2023/07/02 20:31

No.2 回答者： bonaron 回答日時： 2023/07/03 04:03

折角他のご質問で FileSystemObject での回答を頂いたのですから

ここでもそれを使いましょう。

Sub ファイルコピー()
Dim FSO As Object
Dim src As String
Dim dst As String
Set FSO = CreateObject("Scripting.FileSystemObject")
src = ThisWorkbook.Path
dst = src & "\..\検査\"
On Error Resume Next
FSO.CopyFile src & "\*（交付用）.pdf", dst
Set FSO = Nothing
End Sub

参考
http://officetanaka.net/excel/vba/filesystemobje …