マクロについて教えてください。下記のマクロは以前教えて頂いたマクロです。マクロを実行すると指定

Question

マクロについて教えてください。下記のマクロは以前教えて頂いたマクロです。マクロを実行すると指定セル値シート名「青紙表」のセル値「R18」に表示されている、数字と同じ数字を含むフォルダをマクロ有効ブックが保存されているフォルダ内にコピーできます。マクロを実行し、対象フォルダが作業フォルダ内にコピーされた後はコピー元のフォルダは不要になりますのでコピー後に不要フォルダを削除出来る方法を教えてください。例えばセルR18に「12345678」と表示されており検索指定フォルダ先「\nas-sp01\share\確認部\■01_敷地照会回答書\8」内に「ERI12345678（回答）テスト」のフォルダがあると指定セル値「12345678」とフォルダ名の数字「12345678」とが一致いますので「ERI12345678（回答）テスト」が作業フォルダにコピーされます。コピー後は「\nas-sp01\share\確認部\■01_敷地照会回答書\8」内にあるコピー元の「ERI12345678（回答）テスト」が不要になりますので、削除したいのですがこのマクロに追加のコードで削除出来る方法を教えてください。現状のマクロ 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) If strKeyword = "" Then MsgBox ("キーワードが空白です"): Exit Sub 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.CopyFolder arrMoveFolders(0, i), strDestPath & "" & arrMoveFolders(1, i) Next End Sub 以上となります。よろしくお願いいたします。

河内のおやじ · Accepted Answer

Sub マクロ実行()

' コピー元のフォルダパスを取得
    Dim 元フォルダ As String
    元フォルダ = "C:\元のフォルダ\"

' コピー先のフォルダパスを取得
    Dim コピー先フォルダ As String
    コピー先フォルダ = ThisWorkbook.Path & "\コピー先フォルダ\"

' マクロ有効ブックのシート「青紙表」のセル「R18」から値を取得
    Dim 対象数字 As Variant
    対象数字 = Sheets("青紙表").Range("R18").Value

' コピー元のフォルダ内の対象数字を含むフォルダを検索
    Dim 対象フォルダ As String
    対象フォルダ = Dir(元フォルダ & "*" & 対象数字 & "*")

' 対象フォルダが見つかった場合はコピーしてから削除
    If 対象フォルダ <> "" Then
        ' フォルダをコピー
        FileCopy 元フォルダ & 対象フォルダ, コピー先フォルダ & 対象フォルダ
        
        ' コピー後に元フォルダを削除（注意: これにより元フォルダは完全に削除されます）
        Kill 元フォルダ & 対象フォルダ
    Else
        MsgBox "対象のフォルダが見つかりませんでした。"
    End If

End Sub

Qchan1962 · Answer

>やはり、同じく、該当フォルダが移動できませでした
残念です
テスト環境を作れないため　こちらで検証していないコードですみません
＞下船させていただきます

ご質問への回答ではありません
言葉足らずでした　病欠多発で非常コックを開けざる負えなく時間がありませんの意でした

＞https://oshiete.goo.ne.jp/qa/13711441.html
に再、質問をさせて頂いております。
今までのコードでアレンジできると思います

趣味替わりもあり興味もあまりないですしExcelVBAも日常で使う機会もないので暇のある時だけになると思います

余談です
常々思う事ですが　仕事で使われているようですので必然的に生産性があると思われます
このようなQAサイトで製作依頼めいたことをせずプロに委託するべきです
もっともご質問者様が開発を担当し給金をもらっているなら違う問題でしょか

Qchan1962 · Answer

＃２です＞ディスクトップ上に作成しましたフォルダ内にマクロブックを設定して実行すると上手く行きましたが、仮に「C:\Users\160931\Desktop\1月10日\テスト」ネットワーク上に仮に「\nas-sp01\share\確認部\電子申請　関連\２．審査中」にマクロブックを設定すると該当フォルダがあります、メッセージが表示され、移動しますが、で「OK」をクリックすると少しマクロを実行しているタイムがありますが、対象フォルダは移動できませんでした。単純に勘違いされています？作業ブック strDestPath = ThisWorkbook.Path 仮に「\nas-sp01\share\確認部\電子申請　関連\２．審査中」面倒なので　本ご質問のコードにpowershell移動コマンドを加えてみます環境によるものなら出来ないかもですが　テストしてみてください 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) If strKeyword = "" Then MsgBox ("キーワードが空白です"): Exit Sub 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 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 補---- Do Until strFolderName = ""については既に回答していますので割愛知恵の Sub Macro1() Dim i As Long Dim strKeyword As String Dim strFolderPath As String, strFolderName As String Dim arrMoveFolders As Variant ・・ Private Function FolderPicker() As String のご質問は削除されたのでしょうかね？このあたりで下船させて頂きます

河内のおやじ · Answer

ネットワーク上のフォルダにアクセスする場合、いくつかの理由で移動できない可能性があります。以下の点を確認してみてください：

1. **ネットワーク共有の権限**: マクロが実行されているユーザーアカウントに、ネットワーク上のフォルダへの読み取りおよび書き込みの権限があるか確認してください。

2. **ネットワークの接続**: マクロが実行される際にネットワークが正しく接続されていることを確認してください。ネットワーク接続が不安定な場合、フォルダへのアクセスが妨げられることがあります。

3. **ネットワークパスの指定**: ネットワーク上のフォルダを指定する際、正しい形式で指定されているか確認してください。UNCパス（例: `\nas-sp01\share\確認部\電子申請　関連\２．審査中`）が正しく入力されているか確認しましょう。

4. **ネットワークの応答時間**: フォルダの移動が少し時間がかかる場合があるかもしれません。ネットワーク上での操作は、ローカルよりも時間がかかることがあります。そのため、実行に時間をかけてみてください。

これらの点を確認した上で、問題が解決しない場合は、デバッグメッセージを追加して詳細な情報を取得するか、エラーが発生するか確認することが役立つでしょう。

河内のおやじ · Answer

解決するために以下の点を確認してみてください：

1. **セル「R18」の値の確認**: マクロ有効ブックのシート「青紙表」のセル「R18」に表示されている数字が正しいか確認してください。もしもセルが空白であるか、正しい数字が入力されていない場合、対象フォルダが見つからないエラーが発生します。

2. **元フォルダのパスの確認**: `元フォルダ` の指定が正しいことを確認してください。もしもフォルダが存在しないか、誤ったパスが指定されている場合も、対象フォルダが見つからないエラーが発生します。

3. **デバッグメッセージの追加**: デバッグメッセージを追加して、どの段階でエラーが発生しているか確認することができます。例えば、以下のようなコードを挿入してみてください：

```vba
    MsgBox "元フォルダ: " & 元フォルダ & vbCrLf & "対象数字: " & 対象数字 & vbCrLf & "対象フォルダ: " & 対象フォルダ
    ```

これにより、どの変数がどのような値を持っているかがメッセージボックスで表示されます。エラーの原因を見つけやすくなるかもしれません。

これらの手順を試しても問題が解決しない場合、もう一度教えていただければと思います。

Qchan1962 · Answer

>>作業フォルダにコピーされます。
コピー後は「\nas-sp01\share\確認部\■01_敷地照会回答書\8」内にあるコピー元の「ERI12345678（回答）テスト」が不要になりますので、削除したい

コピーして削除＝移動　ではありませんか？
FSO.CopyFolderは
https://oshiete.goo.ne.jp/qa/13708768.html
のご質問でnasの制限で出来ない作業の代替えで示したものと記憶しています

＃３に示したもので移動が出来ないのでしょうか？

マクロについて教えてください。 下記のマクロは以前教えて頂いたマクロです。 マクロを実行すると 指定

Sub マクロ実行()

>やはり、同じく、該当フォルダが移動できませでした

＃２です

ネットワーク上のフォルダにアクセスする場合、いくつかの理由で移動できない可能性があります。

解決するために以下の点を確認してみてください：

>>作業フォルダにコピーされます。

似たような質問が見つかりました

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング

マクロについて教えてください。下記のマクロは以前教えて頂いたマクロです。マクロを実行すると指定