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

下記のマクロはネットから参照したマクロで、マクロを実行すると指定フォルダが圧縮できます。
このマクロでが圧縮対象のフォルダを
targetPath = "C:\Users\160931\Desktop\ファイル更新（最新）\テスト物件\12345678-5_交付用"
'作成するZIPファイルのパスを
zipFilePath = "C:\Users\160931\Desktop\ファイル更新（最新）\テスト物件\12345678-5_交付用.zip"
に指定しておりますが、
この指定を
マクロ設定ブックと同じフォルダ内にある、フォルダ「12345678-5_交付用」に変更出来る方法を教えてください。
尚、圧縮対象フォルダは1つしか無く、「_交付用」は固定フォルダ名になりますが、
「_交付用」から前の部分（12345678-5）は物件毎に変更になる為、
' フォルダ名が「8桁の英数字-1_交付用」というパターンに一致する場合
If folderName Like "########-#_交付用" Then
のような設定を希望いたします。
現状のマクロ
Sub フォルダを圧縮()
Dim targetPath As String
Dim zipFilePath As String
Dim psCommand As String
Dim wsh As Object
Dim result As Integer

'ZIP形式で圧縮するフォルダ(またはファイル)パスを指定
targetPath = "C:\Users\160931\Desktop\ファイル更新（最新）\テスト物件\12345678-5_交付用"

'作成するZIPファイルのパスを指定
zipFilePath = "C:\Users\160931\Desktop\ファイル更新（最新）\テスト物件\12345678-5_交付用.zip"

'実行するPowerShellのコマンドレットを組み立て
psCommand = "powershell -NoProfile -ExecutionPolicy Unrestricted Compress-Archive -Path " & targetPath & " -DestinationPath " & zipFilePath & " -Force"

Set wsh = CreateObject("WScript.Shell")

'PowerShellのコマンドレットを実行
result = wsh.Run(Command:=psCommand, WindowStyle:=0, WaitOnReturn:=True)

If (result = 0) Then
MsgBox ("圧縮が正常終了しました。")
Else
MsgBox ("圧縮が異常終了しました。")
End If

'後片付け
Set wsh = Nothing

End Sub
以上となります。
宜しくお願い致します。

No.1 ベストアンサー 回答者： tatsumaru77 回答日時： 2024/11/18 09:51

以下のようにしてください。

Sub フォルダを圧縮()
Dim targetPath As String
Dim zipFilePath As String
Dim psCommand As String
Dim wsh As Object
Dim result As Integer
Dim folname As String

folname = Dir(ThisWorkbook.path & "\" & "????????-?_交付用", vbDirectory)
If folname = "" Then
MsgBox ("該当フォルダなし")
Exit Sub
End If
'ZIP形式で圧縮するフォルダ(またはファイル)パスを指定
targetPath = ThisWorkbook.path & "\" & folname
'作成するZIPファイルのパスを指定
zipFilePath = targetPath & ".zip"

'実行するPowerShellのコマンドレットを組み立て
psCommand = "powershell -NoProfile -ExecutionPolicy Unrestricted Compress-Archive -Path " & targetPath & " -DestinationPath " & zipFilePath & " -Force"

Set wsh = CreateObject("WScript.Shell")

'PowerShellのコマンドレットを実行
result = wsh.Run(Command:=psCommand, WindowStyle:=0, WaitOnReturn:=True)

If (result = 0) Then
MsgBox ("圧縮が正常終了しました。")
Else
MsgBox ("圧縮が異常終了しました。")
End If

'後片付け
Set wsh = Nothing

End Sub

この回答へのお礼

回答ありがとうございます。
この度も助けて頂けましてありがとうございました。
全て上手く行きました。
感謝いたします。

お礼日時：2024/11/18 09:56