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

下記のマクロは先日教えて頂いたマクロで
指定セル値の数字が該当した場合に移動元のフォルダが作業ブックに移動できるマクロになっておりますが、
移動元のフォルダ指定のコードが
「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

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

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

• 

  移動先のフォルダが
  「strOriginPath = "\\nas-sp01\share\確認部\■01_敷地照会回答書"」の場合のみ、エラーがでてしまい、マクロが実行できません。
  フォルダ名に原因があるのかを調べるために、
  色々とおこなってみましたが、
  移動先のフォルダ名が「\\nas-sp01\share\」から始まる場合にエラーが出てしまい、
  「C:\Users\160931\Desktop\」
  から始まる場合には上手く実行が出来ます。
  移動先のフォルダがネットワークに問題があるのでしょうか。
  何が原因なのかが、不明です。大変困っております。
  先日、親切に教えて頂けた方を含めて、何卒、よろしくお願いいたします。
  解決方法を教えてください。

    補足日時：2024/01/15 10:55

• 

  回答ありがとうございます。
  先日も助けて頂きまして感謝いたします。
  申し訳ありません。
  エラー「70」でした。
  貴者の追加コード
  strKeyword = CStr(Sheets("青紙表").Range("R18").Value)
  の下に
  If strKeyword = "" Then MsgBox ("キーワードが空白です"): Exit Sub
  を追加しましたが、やはり伊那路エラーが出てしまいます。
  以前、貴者に色々と助けて頂いた、マクロで同じように
  「\\nas-sp01\share\確認部\」から始まるファルダ先を指定しておりますが、このようになるのは初めてです。
  何がおかしいのでしょうか？
  よろしくお願いいたします。

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

• 回答ありがとうございます。
  代替え案迄考えて頂きまして、ありがとうございます。
  コピーであれば、上手くできました。
  別マクロにて
  コピー後のフォルダを削除出来る方法はありますでしょうか、
  「\\nas-sp01\share\確認部\■01_敷地照会回答書」サブフォルダにあるフォルダ
  「0」～「9」までのフォルダ内にある各フォルダに保存されているフォルダは基本的に各自が移動して
  使用し、使用後は「0」～「9」までのフォルダ内にある各フォルダは無いものとすることが社内ルールとなっております。
  この質問は新しい質問となりますので、
  ご連絡後、改めてご質問をさせて頂きます。何卒、よろしくお願いいたします。

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

• 試験的に
  青紙表のセルR18には「12345678」の数字を表示しており、
  移動先フォルダ
  「\\nas-sp01\share\確認部\■01_敷地照会回答書\8」に
  「ABC12345678（回答）テスト」名のフォルダを作成しております。
  教えて頂けたコピーで
  ERI12345678（回答）テスト
  のフォルダをコピーができました。
  試しに
  手動で
  「\\nas-sp01\share\確認部\■01_敷地照会回答書\8」にある
  「ABC12345678（回答）テスト」を右クリックで削除を選択すると削除することが出来ました。
  何度も申し訳ありません。
  よろしくお願いいたします。

    補足日時：2024/01/15 16:51

• 何時も助けて頂きましてありがとうございます。
  全て私の希望通りにできました。感謝　感謝です。
  甘えついでに申し訳ありません、
  今回教えて頂いたマクロコードを利用して
  少し変更したい内容のマクロを教えて頂きたく、
  新しい質問をさせいただきますので
  勝手ですが、是非、又、助けて頂けると幸いです。
  よろしくお願いいたします。

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

No.1 ベストアンサー 回答者： Qchan1962 回答日時： 2024/01/15 13:48

回答ではありません

引き続き回答できるかわかりませんが（趣味替わりの為）よく理解できない点を

＞「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
のように１行加えておいた方が良いと思います・・・たぶん。

No.3 回答者： Qchan1962 回答日時： 2024/01/15 19:07

試しに手動で

「\\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

この回答へのお礼

ありがとうございます
詳しいコードも教えて頂き
何時も最後まで
対応して頂き感謝いたします
早速試してみます
後ほど結果をご連絡差し上げます

お礼日時：2024/01/15 20:43

No.2 回答者： Qchan1962 回答日時： 2024/01/15 14:57

＃１　エラーが70なら

"\\nas-sp01\share\確認部\■01_敷地照会回答書"のアクセス権限を調べ対応する方法になるかと・・・・

Directoryの移動や削除となるとアクセス権限によると思いますのでネットワーク管理者と相談してみて下さい
環境でどうなのかわかりませんが　
VBA　NAS　アクセス権限などで調べてみるとか・・・

NASのフォルダは消したいのかな？
諦めて　代案として
フォルダを消さないでThisWorkbook.Path配下にコピーだとダメかな？

例 fso.CopyFolder

エラー行
fso.CopyFolder arrMoveFolders(0, i), strDestPath & "\" & arrMoveFolders(1, i)

ファイルアクセスできるようですのでフォルダコピーができると思います