下記のマクロは先日教えて頂いたマクロで、マクロを実行すると指定セル値に該当するサブフォルダ名がマクロ設定ブックと同じフォルダ内に移動できます。
このマクロを下記の内容に変更出来る方法を教えてください。
指定セル値「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
以上となります。よろしくお願いいたします。
No.2ベストアンサー
- 回答日時:
書くのが面倒でしたので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
No.1
- 回答日時:
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
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
似たような質問が見つかりました
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2024/01/12 16:09
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2023/11/09 11:51
- Visual Basic(VBA) エクセルのマクロについて教えてください。 3 2023/11/08 10:31
- Visual Basic(VBA) エクセルのマクロについて教えてください。 2 2023/10/19 17:13
- Excel(エクセル) マクロのコードを、少しでも削って短くしたい 3 2022/08/30 07:46
- Visual Basic(VBA) エクセルのマクロについて教えてください。 4 2023/07/03 09:11
- Excel(エクセル) 2つのVBAを一緒にしたら機能しなくなりました(エクセル) 7 2022/06/02 12:41
- Visual Basic(VBA) エクセルのマクロについて教えてください。 3 2023/02/17 11:59
- Visual Basic(VBA) エクセルのマクロについて教えてください。 3 2023/02/22 08:53
- Visual Basic(VBA) エクセルのマクロについて教えてください。 7 2023/07/04 09:18
このQ&Aを見た人はこんなQ&Aも見ています
-
「環境が人を育てる」って本当?環境によって人格や生き方は本当に変わるのか
環境が人生に与える影響は実際どれほどのものなのか、専門家の田宮由美さんに伺った。
-
VBAのコードを教えてください
Visual Basic(VBA)
-
Cellsのコードが打てません
Visual Basic(VBA)
-
エクセルのマクロについて教えてください。
Visual Basic(VBA)
-
-
4
ユーザーフォームに別シートからデータを反映させたい。
Visual Basic(VBA)
-
5
マクロについて教えてください。 下記のマクロは以前教えて頂いたマクロです。 マクロを実行すると 指定
Visual Basic(VBA)
-
6
エクセルVBAでデータ転記
Visual Basic(VBA)
-
7
Excel マクロについて
Visual Basic(VBA)
-
8
VBAを教えていただきたいです。 添付のような「data sheet」があります。 他に、「集計 s
Visual Basic(VBA)
-
9
Excel VBAマクロをマスターするのに、どれ位時間掛かりますか?
Visual Basic(VBA)
-
10
ご教授お願いします。#NUM!が解消されません。
Visual Basic(VBA)
-
11
VBA コード
Visual Basic(VBA)
-
12
Excelセルに入力された文字の色を変える方法を教えてください
Visual Basic(VBA)
-
13
お世話になります。 Excel VBAのプログラムについてご教授をお願いいたします。 添付した写真よ
Visual Basic(VBA)
-
14
excelのVBAについて、以下のコードに追加をお願いいたします。
Visual Basic(VBA)
-
15
VBAコードが作動しません。修正したいのですが何処に原因かあるか教えて下さい。
Visual Basic(VBA)
-
16
VBA実行後に元のセルに戻りたい
Visual Basic(VBA)
-
17
ExcelのVBAコードについて教えてください。
Visual Basic(VBA)
-
18
エクセルVBAの配列について
Visual Basic(VBA)
-
19
データから単位文字を除去して計算する方法は?
Excel(エクセル)
-
20
エクセル VBAでの転記の方法について
Visual Basic(VBA)
関連するカテゴリからQ&Aを探す
このQ&Aを見た人がよく見るQ&A
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
特定のPCだけ動作しないVBAマク...
-
Excel・Word リサーチ機能を無...
-
メッセージボックスのOKボタ...
-
Excel マクロ VBA プロシー...
-
エクセルで特定の列が0表示の場...
-
TERA TERMを隠す方法
-
wordを起動した際に特定のペー...
-
一つのTeratermのマクロで複数...
-
ExcelVBAでPDFを閉じるソース
-
特定文字のある行の前に空白行...
-
マクロ実行時、ユーザーフォー...
-
Excel VBAからAccessマクロを実...
-
EXCELマクロでのThisisWor...
-
ExcelVBA 図形をクリックした...
-
ExcelのVBA。public変数の値が...
-
非表示の列をすべて削除するマクロ
-
EXCELのVBAでRange("A1:C4")を...
-
VBAで特定の文字を含まない列の...
-
uwscの使い方について。ifの前...
-
エクセル マクロ 指定日の指定...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
Excel・Word リサーチ機能を無...
-
エクセルで特定の列が0表示の場...
-
特定のPCだけ動作しないVBAマク...
-
Excel マクロ VBA プロシー...
-
メッセージボックスのOKボタ...
-
一つのTeratermのマクロで複数...
-
ExcelのVBA。public変数の値が...
-
Excel VBAからAccessマクロを実...
-
EXCELのVBAでRange("A1:C4")を...
-
ExcelVBAでPDFを閉じるソース
-
エクセルに張り付けた写真のフ...
-
エクセルで別のセルにあるふり...
-
TERA TERMを隠す方法
-
2つのマクロでチェックボックス...
-
マクロ実行時、ユーザーフォー...
-
【マクロ】1つのマクロの中に...
-
ピボットテーブルでの毎回可変...
-
特定文字のある行の前に空白行...
-
エクセルのマクロについて教え...
-
wordを起動した際に特定のペー...
おすすめ情報
回答ありがとうございました。
何時もご連絡ありがとうございます。
大変申し訳ありません、
フォルダピッカー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
をどのように設定してよいかが、わかりません。
お手数をお掛け致しますが、
教えていただけますでしょうか。
よろしくお願いいたします。
回答ありがとうございます。
上手くできました。
別件で
昨日教えて頂きましたマクロで、少々解決したい問題が発生いたしました。
別質問をさせて頂きます、
何卒、お助けください。
よろしくお願いいたします。