
下記のマクロは先日教えて頂いたマクロで
指定セル値の数字が該当した場合に移動元のフォルダが作業ブックに移動できるマクロになっておりますが、
移動元のフォルダ指定のコードが
「strOriginPath = "C:\Users\160931\Desktop\新しいフォルダ\■01_敷地照会回答書"」の場合は上手くマクロが実行されますが
「strOriginPath = "\\nas-sp01\share\確認部\■01_敷地照会回答書"」の場合にはエラー表示が出てしまい、
コードの
「FSO.GetFolder(arrMoveFolders(0, i)).Move strDestPath & "\" & arrMoveFolders(1, i)」部分が黄色くなりマクロが実行できません。
解決方法を教えてください。
現状のマクロ
Sub 行政回答フォルダ確認()
Dim i As Long
Dim FSO As Object
Dim strKeyword As String
Dim strFolderPath As String, strFolderName As String
Dim arrMoveFolders As Variant
Dim strOriginPath As String, strDestPath As String
If MsgBox("フォルダを検索しますか", vbOKCancel) <> vbOK Then Exit Sub
Set FSO = CreateObject("Scripting.FileSystemObject")
strKeyword = CStr(Sheets("青紙表").Range("R18").Value)
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
strFolderName = Dir(strFolderPath & "\*" & strKeyword & "*", vbDirectory)
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
For i = 0 To UBound(arrMoveFolders, 2)
FSO.GetFolder(arrMoveFolders(0, i)).Move strDestPath & "\" & arrMoveFolders(1, i)
Next
End Sub
以上となります。
よろしくお願いいたします。

No.1ベストアンサー
- 回答日時:
回答ではありません
引き続き回答できるかわかりませんが(趣味替わりの為)よく理解できない点を
>「strOriginPath = "\\nas-sp01\share\確認部\■01_敷地照会回答書"」の場合のみ、エラーがでてしまい、マクロが実行できません。
>「C:\Users\160931\Desktop\」から始まる場合には上手く実行が出来ます。
エラーって76? 70ではないですか?
処理構成をみるとstrOriginPathを変えて76がそこで返る可能性は低いと思います
strFolderPathにサブフォルダ名を付加して代入し
strFolderName = Dir(strFolderPath & "\*" & strKeyword & "*", vbDirectory)
Do Until strFolderName = ""
Dir関数で取得しているから・・・存在しなければパスは配列に入らないと思います(試してないけれど)
エラーが70なら
"\\nas-sp01\share\確認部\■01_敷地照会回答書"のアクセス権限を調べ対応する方法になるかと・・・・
関係ないですが書いてて思ったこと
strFolderName = Dir(strFolderPath & "\*" & strKeyword & "*", vbDirectory)
Do Until strFolderName = ""
これにはバグが潜んでいるかと・・・
上部
strKeyword = CStr(Sheets("青紙表").Range("R18").Value)
の下に
If strKeyword = "" Then MsgBox ("キーワードが空白です"): Exit Sub
のように1行加えておいた方が良いと思います・・・たぶん。
No.3
- 回答日時:
試しに手動で
「\\nas-sp01\share\確認部\■01_敷地照会回答書\8」にある
「ABC12345678(回答)テスト」を右クリックで削除を選択すると削除することが出来ました。
nasの対象フォルダを削除(移動)したいという事ですね
環境によりうまくいくかはわかりませんが
経緯上フォルダーを移動するテストコードです
powershell でMove-Itemコマンドを実行しています
Sub 行政回答フォルダ確認()
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
- 回答日時:
#1 エラーが70なら
"\\nas-sp01\share\確認部\■01_敷地照会回答書"のアクセス権限を調べ対応する方法になるかと・・・・
Directoryの移動や削除となるとアクセス権限によると思いますのでネットワーク管理者と相談してみて下さい
環境でどうなのかわかりませんが
VBA NAS アクセス権限などで調べてみるとか・・・
NASのフォルダは消したいのかな?
諦めて 代案として
フォルダを消さないでThisWorkbook.Path配下にコピーだとダメかな?
例 fso.CopyFolder
エラー行
fso.CopyFolder arrMoveFolders(0, i), strDestPath & "\" & arrMoveFolders(1, i)
ファイルアクセスできるようですのでフォルダコピーができると思います
お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!
関連するカテゴリからQ&Aを探す
今、見られている記事はコレ!
-
隣の枝がはみ出してきたら切ってもいい?最もやってはいけないことは?
「隣の木が越境してきて困るが、勝手に切ってはいけないと聞くし…」そう思っている方も多いだろう。実は、2023年4月1日に民法が改正され、この「越境枝」のルールが大きく変わった。 教えて!gooでも「境界から出て...
-
弁護士が解説!あなたの声を行政に届ける「パブリックコメント」制度のすべて
社会に対する意見や不満、疑問。それを発信する場所は、SNSやブログ、そしてニュースサイトのコメント欄など多岐にわたる。教えて!gooでも「ヤフコメ民について」というタイトルのトピックがあり、この投稿の通り、...
-
弁護士が語る「合法と違法を分けるオンラインカジノのシンプルな線引き」
「お金を賭けたら違法です」ーーこう答えたのは富士見坂法律事務所の井上義之弁護士。オンラインカジノが違法となるかどうかの基準は、このように非常にシンプルである。しかし2025年にはいって、違法賭博事件が相次...
-
釣りと密漁の違いは?知らなかったでは済まされない?事前にできることは?
知らなかったでは済まされないのが法律の世界であるが、全てを知ってから何かをするには少々手間がかかるし、最悪始めることすらできずに終わってしまうこともあり得る。教えてgooでも「釣りと密漁の境目はどこです...
-
カスハラとクレームの違いは?カスハラの法的責任は?企業がとるべき対応は?
東京都が、客からの迷惑行為などを称した「カスタマーハラスメント」、いわゆる「カスハラ」の防止を目的とした条例を、全国で初めて成立させた。条例に罰則はなく、2025年4月1日から施行される。 この動きは自治体...
おすすめ情報
デイリーランキングこのカテゴリの人気デイリーQ&Aランキング
-
特定のPCだけ動作しないVBAマク...
-
エクセルで特定の列が0表示の場...
-
Excelのセル値に基づいて図形の...
-
メッセージボックスのOKボタ...
-
ExcelVBAでPDFを閉じるソース
-
一つのTeratermのマクロで複数...
-
エクセルのマクロでワードの任...
-
マクロ実行時、ユーザーフォー...
-
Excel マクロ VBA プロシー...
-
EXCELマクロでのThisisWor...
-
エクセルで縦に並んだデータを...
-
VBA アドインについて お詳しい...
-
TERA TERMを隠す方法
-
マクロを使用して、A列にある文...
-
Excel マクロでShearePoint先の...
-
VB初心者です。メールから添付...
-
Excel_マクロ_現在開いているシ...
-
UWLSの記録でマクロを作成し使...
-
ピボットテーブルでの毎回可変...
-
Excelのマクロボタンをダブルク...
マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング
-
特定のPCだけ動作しないVBAマク...
-
エクセルで特定の列が0表示の場...
-
一つのTeratermのマクロで複数...
-
メッセージボックスのOKボタ...
-
Excel・Word リサーチ機能を無...
-
ExcelのVBA。public変数の値が...
-
Excel_マクロ_現在開いているシ...
-
Excel マクロ VBA プロシー...
-
TERA TERMを隠す方法
-
エクセルに張り付けた写真のフ...
-
Excelのセル値に基づいて図形の...
-
エクセルで縦に並んだデータを...
-
Excel マクロでShearePoint先の...
-
特定文字のある行の前に空白行...
-
ExcelVBAでPDFを閉じるソース
-
ソース内の行末に\\
-
Excel VBAからAccessマクロを実...
-
wordを起動した際に特定のペー...
-
エクセルで別のセルにあるふり...
-
UWLSの記録でマクロを作成し使...
おすすめ情報
移動先のフォルダが
「strOriginPath = "\\nas-sp01\share\確認部\■01_敷地照会回答書"」の場合のみ、エラーがでてしまい、マクロが実行できません。
フォルダ名に原因があるのかを調べるために、
色々とおこなってみましたが、
移動先のフォルダ名が「\\nas-sp01\share\」から始まる場合にエラーが出てしまい、
「C:\Users\160931\Desktop\」
から始まる場合には上手く実行が出来ます。
移動先のフォルダがネットワークに問題があるのでしょうか。
何が原因なのかが、不明です。大変困っております。
先日、親切に教えて頂けた方を含めて、何卒、よろしくお願いいたします。
解決方法を教えてください。
回答ありがとうございます。
先日も助けて頂きまして感謝いたします。
申し訳ありません。
エラー「70」でした。
貴者の追加コード
strKeyword = CStr(Sheets("青紙表").Range("R18").Value)
の下に
If strKeyword = "" Then MsgBox ("キーワードが空白です"): Exit Sub
を追加しましたが、やはり伊那路エラーが出てしまいます。
以前、貴者に色々と助けて頂いた、マクロで同じように
「\\nas-sp01\share\確認部\」から始まるファルダ先を指定しておりますが、このようになるのは初めてです。
何がおかしいのでしょうか?
よろしくお願いいたします。
回答ありがとうございます。
代替え案迄考えて頂きまして、ありがとうございます。
コピーであれば、上手くできました。
別マクロにて
コピー後のフォルダを削除出来る方法はありますでしょうか、
「\\nas-sp01\share\確認部\■01_敷地照会回答書」サブフォルダにあるフォルダ
「0」~「9」までのフォルダ内にある各フォルダに保存されているフォルダは基本的に各自が移動して
使用し、使用後は「0」~「9」までのフォルダ内にある各フォルダは無いものとすることが社内ルールとなっております。
この質問は新しい質問となりますので、
ご連絡後、改めてご質問をさせて頂きます。何卒、よろしくお願いいたします。
試験的に
青紙表のセルR18には「12345678」の数字を表示しており、
移動先フォルダ
「\\nas-sp01\share\確認部\■01_敷地照会回答書\8」に
「ABC12345678(回答)テスト」名のフォルダを作成しております。
教えて頂けたコピーで
ERI12345678(回答)テスト
のフォルダをコピーができました。
試しに
手動で
「\\nas-sp01\share\確認部\■01_敷地照会回答書\8」にある
「ABC12345678(回答)テスト」を右クリックで削除を選択すると削除することが出来ました。
何度も申し訳ありません。
よろしくお願いいたします。
何時も助けて頂きましてありがとうございます。
全て私の希望通りにできました。感謝 感謝です。
甘えついでに申し訳ありません、
今回教えて頂いたマクロコードを利用して
少し変更したい内容のマクロを教えて頂きたく、
新しい質問をさせいただきますので
勝手ですが、是非、又、助けて頂けると幸いです。
よろしくお願いいたします。