エクセルのマクロについて教えてください。

下記のマクロは先日教えて頂いたマクロで、マクロを実行すると指定セル値に該当するサブフォルダ名がマクロ設定ブックと同じフォルダ内に移動できます。
このマクロを下記の内容に変更出来る方法を教えてください。
指定セル値「R18」に表示されている数字とサブフォルダ名の数字とが一致し、
メッセージボックスで「該当フォルダがありました、フォルダを移動しますか」と表示され、「OK」をクリックすると「ダイアログが開き、自身で指定したフォルダ内に移動できるように変更出来る方法を教えてください。
現状のマクロ
Sub Macro1()
Dim i As Long
Dim strKeyword As String
Dim strFolderPath As String, strFolderName As String
Dim arrMoveFolders As Variant
Dim strOriginPath As String, strDestPath As String
strKeyword = CStr(Sheets("青紙表").Range("R18").Value)
If strKeyword = "" Then MsgBox ("キーワードが空白です"): Exit Sub
If MsgBox("フォルダを検索しますか", vbOKCancel) <> vbOK Then Exit Sub
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
strOriginPath = "\\nas-sp01\share\確認部\■01_敷地照会回答書"
strDestPath = ThisWorkbook.Path
If Right(strDestPath, 1) = "\" Then strDestPath = Left(strDestPath, Len(strDestPath) - Len("\"))
ReDim arrMoveFolders(0 To 1, 0 To 0)
For i = 0 To 9
strFolderPath = strOriginPath & "\" & i
On Error Resume Next
strFolderName = Dir(strFolderPath & "\*" & strKeyword & "*", vbDirectory)
If Err.Number <> 0 Then
MsgBox "エラーが発生しました" & vbCrLf _
& strFolderPath & "\*" & strKeyword & vbCrLf _
& Err.Description, vbExclamation
Exit Sub
End If
Do Until strFolderName = ""
If Replace(strFolderName, ".", "") <> "" Then
If arrMoveFolders(0, 0) <> Empty Then ReDim Preserve arrMoveFolders(UBound(arrMoveFolders, 1), UBound(arrMoveFolders, 2) + 1)
arrMoveFolders(0, UBound(arrMoveFolders, 2)) = strFolderPath & "\" & strFolderName
arrMoveFolders(1, UBound(arrMoveFolders, 2)) = strFolderName
strFolderName = Dir
End If
Loop
Next
If arrMoveFolders(0, 0) = Empty Then
MsgBox "該当フォルダがありません"
Exit Sub
Else
If MsgBox("該当フォルダがありました、フォルダを移動しますか", vbOKCancel) <> vbOK Then Exit Sub
End If
Dim objWSH As Object
Set objWSH = CreateObject("WScript.Shell")
Dim psCmd As String
For i = 0 To UBound(arrMoveFolders, 2)
psCmd = "Move-Item " & arrMoveFolders(0, i) & " " & strDestPath & "\" & arrMoveFolders(1, i)
objWSH.Run "powershell -NoLogo -ExecutionPolicy RemoteSigned -Command " & psCmd, 0, True
Next
End Sub

以上となります。よろしくお願いいたします。

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

• 

  回答ありがとうございました。
  何時もご連絡ありがとうございます。
  大変申し訳ありません、
  フォルダピッカーFunctionを追加（同じモジュール）
  Private Function FolderPicker() As String
  Dim folderPath As Variant
  With Application.FileDialog(msoFileDialogFolderPicker)
  If .Show = 0 Then
  MsgBox "キャンセルしました"
  Exit Function
  End If
  folderPath = .SelectedItems(1)
  End With
  FolderPicker = folderPath
  End Function
  をどのように設定してよいかが、わかりません。
  お手数をお掛け致しますが、
  教えていただけますでしょうか。
  よろしくお願いいたします。

  No.1の回答に寄せられた補足コメントです。 補足日時：2024/01/16 13:45

• 回答ありがとうございます。
  上手くできました。
  別件で
  昨日教えて頂きましたマクロで、少々解決したい問題が発生いたしました。
  別質問をさせて頂きます、
  何卒、お助けください。
  よろしくお願いいたします。

  No.2の回答に寄せられた補足コメントです。 補足日時：2024/01/16 14:54

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2024/01/16 14:05

書くのが面倒でしたのでFunctionにしましたが、しない方が良かったかな？

>をどのように設定してよいかが、わかりません。
メインプロシージャの外に書けばよいです

Sub Macro1()
Dim i As Long
Dim strKeyword As String
Dim strFolderPath As String, strFolderName As String
Dim arrMoveFolders As Variant
Dim strOriginPath As String, strDestPath As String
strKeyword = CStr(Sheets("青紙表").Range("R18").Value)
If strKeyword = "" Then MsgBox ("キーワードが空白です"): Exit Sub
If MsgBox("フォルダを検索しますか", vbOKCancel) <> vbOK Then Exit Sub
Dim FSO As Object
Set FSO = CreateObject("Scripting.FileSystemObject")
strOriginPath = "\\nas-sp01\share\確認部\■01_敷地照会回答書"
If Right(strDestPath, 1) = "\" Then strDestPath = Left(strDestPath, Len(strDestPath) - Len("\"))
ReDim arrMoveFolders(0 To 1, 0 To 0)
For i = 0 To 9
strFolderPath = strOriginPath & "\" & i
On Error Resume Next
strFolderName = Dir(strFolderPath & "\*" & strKeyword & "*", vbDirectory)
If Err.Number <> 0 Then
MsgBox "エラーが発生しました" & vbCrLf _
& strFolderPath & "\*" & strKeyword & vbCrLf _
& Err.Description, vbExclamation
Exit Sub
End If
Do Until strFolderName = ""
If Replace(strFolderName, ".", "") <> "" Then
If arrMoveFolders(0, 0) <> Empty Then ReDim Preserve arrMoveFolders(UBound(arrMoveFolders, 1), UBound(arrMoveFolders, 2) + 1)
arrMoveFolders(0, UBound(arrMoveFolders, 2)) = strFolderPath & "\" & strFolderName
arrMoveFolders(1, UBound(arrMoveFolders, 2)) = strFolderName
strFolderName = Dir
End If
Loop
Next
If arrMoveFolders(0, 0) = Empty Then
MsgBox "該当フォルダがありません"
Exit Sub
Else
If MsgBox("該当フォルダがありました、フォルダを移動しますか", vbOKCancel) <> vbOK Then Exit Sub
strDestPath = FolderPicker　'当該部分
If strDestPath = Empty Then Exit Sub　'当該部分
End If

Dim objWSH As Object
Set objWSH = CreateObject("WScript.Shell")
Dim psCmd As String

For i = 0 To UBound(arrMoveFolders, 2)
psCmd = "Move-Item " & arrMoveFolders(0, i) & " " & strDestPath & "\" & arrMoveFolders(1, i)
objWSH.Run "powershell -NoLogo -ExecutionPolicy RemoteSigned -Command " & psCmd, 0, True
Next
End Sub

'当該部分Function
Private Function FolderPicker() As String　
Dim folderPath As Variant
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = 0 Then
MsgBox "キャンセルしました"
Exit Function
End If
folderPath = .SelectedItems(1)
End With
FolderPicker = folderPath
End Function

この回答へのお礼

お手数をお掛けして申し訳ありません。
何から何まで無知な私をいつも助けて頂きまして
ありがとうございます。
上手く出来ました。

お礼日時：2024/01/16 14:52

No.1 回答者： Qchan1962 回答日時： 2024/01/16 11:21

strDestPath = ThisWorkbook.Path　　不要

該当Ifブロック書き換え

If arrMoveFolders(0, 0) = Empty Then
MsgBox "該当フォルダがありません"
Exit Sub
Else
If MsgBox("該当フォルダがありました、フォルダを移動しますか", vbOKCancel) <> vbOK Then Exit Sub
strDestPath = FolderPicker
If strDestPath = Empty Then Exit Sub
End If

フォルダピッカーFunctionを追加（同じモジュール）

Private Function FolderPicker() As String
Dim folderPath As Variant
With Application.FileDialog(msoFileDialogFolderPicker)
If .Show = 0 Then
MsgBox "キャンセルしました"
Exit Function
End If
folderPath = .SelectedItems(1)
End With
FolderPicker = folderPath
End Function