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

下記の2つのマクロを1つに出来る方法を教えてください。
このマクロは以前教えて頂いたマクロで、マクロを実行すると
指定ファイルが指定フォルダ内に移動します。
マクロ-1
Sub 交付用に移動A3()
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 <> ""
' ファイルの移動を実行
Name myPath(1) & fname As 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")

' 現在のフォルダ内のPDFファイルがあるパスを取得
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
マクロ-2
Sub 交付用に移動A4()
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) & "*（交付用_A4）.pdf")

Do While fname <> ""
' ファイルの移動を実行
Name myPath(1) & fname As 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")

' 現在のフォルダ内のPDFファイルがあるパスを取得
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
以上となります。
よろしくお願いいたします。

No.1 ベストアンサー 回答者： tatsumaru77 回答日時： 2024/12/18 14:00

１．2つのマクロを呼び出す処理を作成します。

Sub 処理結合()
Call 交付用に移動A3
Call 交付用に移動A4
End Sub

２．以下の
Function folder_acquisition(fPath As String) As Variant()
・・・
End Function

が２つあるので、片方を削除します。

以上で完了です。

実際のソースは、以下のようになります。
マクロ実行時は、Sub 処理結合()を呼び出します。
動作確認はしていませんのでご了承ください。
----------------------------------------------------------
Sub 処理結合()
Call 交付用に移動A3
Call 交付用に移動A4
End Sub

Sub 交付用に移動A3()
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 <> ""
' ファイルの移動を実行
Name myPath(1) & fname As 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")

' 現在のフォルダ内のPDFファイルがあるパスを取得
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

Sub 交付用に移動A4()
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) & "*（交付用_A4）.pdf")

Do While fname <> ""
' ファイルの移動を実行
Name myPath(1) & fname As myPath(2) & fname
fname = Dir
Loop
End Sub

この回答へのお礼

回答ありがとうございます。
早速試してみます。

お礼日時：2024/12/18 14:18