Excelのマクロについて教えてください。

下記のマクロを以下の条件のように変更出来る方法を教えてください。
マクロを実行するとワイルドカード名のPDFファイルが指定フォルダから指定フォルダ内にコピーされます。
コードの「Case "検査時必要図書（正本）"」ですが、マクロを設定しているフォルダを指定
（仮に今回はフォルダを「テスト部件」としてます。
コードの「Case "返却用（副本）"」ですがマクロを設定しているフォルダ内のフォルダを指定
（今回は：24110955-1_交付用となっておりますが、最初「_」前の半角英数字と8文字と「-」以下の半角英数字と1文字は物件によって変更されますが、「_交付用」は変更されません。
画像のように
テスト物件フォルダ内にある「24001234-1_（仮称）北海太郎（交付用_A3）.pdf」を
同じくテスト部件内にあるフォルダ名「24001234-1_交付用」内にコピーを出来る方法を教えてください。
できるだけ詳しいコード迄、親切に教えてください。
現状のマクロ
Sub 交付用()
On Error Resume Next
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) & "*（交付用_A3）.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
以上となります。

質問者からの補足コメント

• 回答ありがとうございます。
  早速試してみます。
  後ほど、結果を報告させていただきます。

  No.1の回答に寄せられた補足コメントです。 補足日時：2024/11/08 17:05

No.1 ベストアンサー 回答者： kuukun107 回答日時： 2024/11/08 15:49

このコードを、指定のフォルダ名に基づいてPDFファイルをコピーするように変更する方法について、以下で詳しく解説します。

説明と変更のポイント

1. 「検査時必要図書（正本）」のパス指定
ThisWorkbook.Path でマクロがあるフォルダを取得し、その中の「検査時必要図書（正本）」フォルダを参照します。
2. 「返却用（副本）」フォルダの動的な判定
「返却用（副本）」フォルダは、「8桁の英数字-1_交付用」という名前でフォルダ内に存在するため、そのようなパターンを正規表現で確認して目的のフォルダを特定します。

改良したコード

以下が、マクロを変更したコードです。

Sub 交付用()
On Error Resume Next
Dim myPath As Variant
Dim fPath As String, fname As String
fPath = ThisWorkbook.Path
' myPath 変数にフォルダパスを取得
myPath = folder_acquisition(fPath)
' 「交付用_A3」で終わるPDFファイルを取得
fname = Dir(myPath(1) & "*（交付用_A3）.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")

' 検査時必要図書（正本）フォルダの取得
myPath(1) = fPath & "\検査時必要図書（正本）\"

' フォルダ内のサブフォルダを走査し、「_交付用」で終わるものを見つける
For Each f In fso.GetFolder(fPath).SubFolders
Dim folderName As String
folderName = Mid(f.Path, InStrRev(f.Path, "\") + 1)

' フォルダ名が「8桁の英数字-1_交付用」というパターンに一致する場合
If folderName Like "########-#_交付用" Then
myPath(2) = f.Path & "\"
n = n + 1
End If

' 必要なフォルダが見つかったら終了
If n = 2 Then Exit For
Next f

Set fso = Nothing
folder_acquisition = myPath()
End Function

コードの詳細な説明

1. メインプロシージャ 交付用()
• fPath をマクロの保存されているフォルダに設定します。
• folder_acquisition(fPath) を呼び出して、必要なフォルダのパスを myPath に取得します。
• myPath(1) の中にある「交付用_A3」で終わるPDFファイルをループで探し、myPath(2) にコピーします。
2. 補助関数 folder_acquisition(fPath As String) As Variant()
• myPath(1) に「検査時必要図書（正本）」フォルダのパスを直接指定しています。
• For Each f In fso.GetFolder(fPath).SubFolders でサブフォルダをループし、フォルダ名が「8桁の英数字-1_交付用」に一致するものを探します。
• Like "########-#_交付用" の条件を使い、該当するフォルダのパスを myPath(2) に格納します。

動作確認

1. 実行前に「検査時必要図書（正本）」フォルダと、「8桁の英数字-1_交付用」に一致するフォルダが存在することを確認します。
2. マクロを実行し、指定フォルダにファイルが正しくコピーされるかを確認します。

これで、「検査時必要図書（正本）」と「8桁の英数字-1_交付用」フォルダ間でPDFファイルのコピーが行われるはずです。


上記は生成AIの解答です。
参考になれば幸いです。

この回答へのお礼

お礼日時：2024/11/13 08:17