• ベストアンサー
※ ChatGPTを利用し、要約された質問です(原文:エクセルVBAでBOOKに読み取りパスワード設定)

エクセルVBAでサブフォルダ内のBOOKも対象にする方法を教えてください

このQ&Aのポイント
  • エクセル2013で、指定した任意のフォルダ内のエクセルに読み取りパスワードを設定するVBAコードがあります。しかし、そのフォルダの下にサブフォルダがある場合、サブフォルダ内のエクセルは対象になりません。サブフォルダも対象にする方法を教えてください。
  • エクセルVBAを使用して、エクセル2013で指定したフォルダ内のエクセルに読み取りパスワードを設定するコードがあります。しかし、このコードでは、サブフォルダ内のエクセルファイルは対象になりません。どのように修正すれば、サブフォルダも対象にすることができるでしょうか?教えてください。
  • エクセル2013で使用するVBAコードにより、指定したフォルダ内のエクセルに読み取りパスワードを設定することができます。しかし、このコードはサブフォルダ内のエクセルには適用されません。どのようにすれば、サブフォルダも対象にすることができるのでしょうか?お教えください。

質問者が選んだベストアンサー

  • ベストアンサー
回答No.1

こんにちは。 "サブフォルダ"内のファイルに纏わる直接的な回答としては、 fsoを再帰処理と組み合わせる方法を紹介するのが 最もポピュラーな(一般認知度の高い)対応だと思います。 ただ、FolderPickerでフォルダを指定させるということだと、 例えば、ドライブまるごと"D:\"のような指定も可能になりますし、 指定されたフォルダによっては膨大な処理量にもなり兼ねません。 ですので、"サブフォルダも対象"ということだと、 (fsoであれDirであれ、再帰であれ非再帰であれ必ず) 何れかの段階で適当な制限を設けた上で実装することになります。 そういう意味では、実際の運用から離れた立場で、 安直にサンプルを提示することには非常に抵抗があります。 具体的な記述を掲げたとしても決してピンポイントな解答にはなり得ないこと、 そちらでの注意深い応用に委ねる部分が大きいことを理解しておいてください。 よくある設問としては、   サブフォルダの階層数を制限する   EscやBreakで処理を中断できるようにする   一定の件数毎に処理継続を問うようにする 等の対処を組み合わせて、 膨大な処理量による待ち時間やトラブルを回避できるようにするとか、、、ですね。 この点、★や■マークの行にて幾つか(あくまでも一例として)書いてみました。 過不足あれば、そちらで修正してみてください。 尚、以下の点については対策していません。   自ブックまたは既に開いているブックに対する.Open処理の排除   処理を途中で中止した場合のトランザクション   "リンクの更新"等、開くと問われるダイアログ また、Application.DisplayAlertsについては、 各ブックを開いて保存する度に繰り返し設定変更の必要があるのか、 私には判断できませんので、ご提示の記述を踏襲します。 動作確認した環境は、win7 xl2010(x64)です。 ' === Option Explicit ' /// モジュール宣言部 Private oFSO As Object ' ▼ 参照設定しない場合 'Private oFSO As Scripting.FileSystemObject ' ▲ Scripting 参照設定 [Microsoft Scripting Runtime] Private wkb0 As Workbook Private n As Long Private flgEsc As Boolean ' ★ 処理の中断を可能にする為の記述 ' /// 実行マクロ Sub ReW9054138() Dim myfdr As String   With Application.FileDialog(msoFileDialogFolderPicker) '対象とするフォルダの指定     If .Show = True Then       myfdr = .SelectedItems(1)     Else       MsgBox "キャンセルします。", vbInformation       Exit Sub     End If   End With   Set wkb0 = ThisWorkbook 'このコピー先ブックをwkb0とする。   Set oFSO = CreateObject("Scripting.FileSystemObject") ' ▼ FSO を設定 '  Set oFSO = New Scripting.FileSystemObject ' ▲   n = 1 ' ●カウンタのオリジンは 1   flgEsc = False ' ★ '  Application.ScreenUpdating = False ' ? '  Application.EnableEvents = False ' ?   Call ブック検索(myfdr) '  Application.EnableEvents = True ' ? '  Application.ScreenUpdating = True ' ?   Set oFSO = Nothing   If flgEsc Then ' ★     MsgBox n - 1 & "件処理して、中断しました。", vbExclamation ' ★●カウンタのオリジンは 1   Else     MsgBox n - 1 & "件処理しましました。", vbInformation ' ●カウンタのオリジンは 1   End If End Sub ' /// サブ Private Sub ブック検索(ByVal sFolder As String, Optional ByVal nDim As Long) Dim oFile As Object ' ▼ 'Dim oFile As Scripting.File ' ▲ Dim oFolder As Object ' ▼ 'Dim oFolder As Scripting.Folder ' ▲ Dim sFile As String   With oFSO.GetFolder(sFolder)     For Each oFile In .Files ' フォルダ内の ファイルを 全て検索       If flgEsc Then Exit For ' ★       DoEvents: DoEvents ' ★       sFile = oFile.Path       If LCase(oFSO.GetExtensionName(sFile)) Like "xls*" Then ' 拡張子判定         Call 個別処理(sFile)       End If     Next '    If nDim > 0 Then Exit Sub ' 例■サブフォルダの階層数をひとつ下までと制限する場合 イキ     For Each oFolder In .SubFolders ' フォルダ内の サブフォルダを 全て検索       If flgEsc Then Exit For ' ★       DoEvents: DoEvents ' ★       Call ブック検索(oFolder.Path, nDim + 1) ' サブフォルダのパスを引数に 再帰処理     Next   End With End Sub ' /// サブサブ Private Sub 個別処理(ByVal sFile As String) Dim wb As Workbook   If flgEsc Then Exit Sub ' ★   If n > 1 And n Mod 100 = 1 Then ' 100件毎に処理継続を問う例★●カウンタのオリジンは 1     If MsgBox(n - 1 & "件処理しましました。" & vbLf & "続行しますか?", vbInformation + vbYesNo) = vbNo Then ' ★●カウンタのオリジンは 1       flgEsc = True ' ★       Exit Sub     End If   End If   n = n + 1 ' ●カウンタ   On Error GoTo ErrOpen_ ' ◆ブックを開けない場合をトラップ   Set wb = Workbooks.Open(sFile) 'そのブックを開きwbとする。   On Error GoTo 0 ' ◆   With wkb0.Sheets("Sheet1") '転記     .Cells(n, "B").Value = sFile     .Cells(n, "C").Value = wb.Sheets(1).Range("B1").Value   End With   Application.DisplayAlerts = False   wb.SaveAs Filename:=wb.FullName, Password:="emaxemax"   wb.Close SaveChanges:=False   Application.DisplayAlerts = True Exit_: ' ◆   Exit Sub ' ◆ ErrOpen_: ' ◆   With wkb0.Sheets("Sheet1") ' ◆     .Cells(n, "B").Value = sFile ' ◆     .Cells(n, "C").Value = "Err:" & Err.Number ' ◆   End With ' ◆ End Sub ' === もしも、fsoや再帰処理を用いない方法をお求めということでしたら、   半角チルダ>『■Dir再帰|非再帰』 http://blog.goo.ne.jp/end-u/e/2a9f0ed1e468f4dfaa36c2af2c04e714 大いに参考になることと思います。 以上です。

emaxemax
質問者

お礼

realbeatin さん、今回もありがとうございます。 ご教示いただいた方法で目的を達することができました。 ご指摘いただいた注意点も、例えばリンクの更新は UpdateLinks:=0 を入れ対応するなどいたしました。細かい点までご配慮いただき、深く感謝いたします。 これからもよろしくお願いいたします。 ありがとうございました。

emaxemax
質問者

補足

> そういう意味では、実際の運用から離れた立場で、 > 安直にサンプルを提示することには非常に抵抗があります。 すみません、使用する状況をちゃんと書くべきでしたね。 今回は個人情報管理の問題から、サーバー内の特定のフォルダ(下にサブフォルダが2階層まであります)内のエクセルデータにすべて読取りパスワードを設定する作業です。まだ実施しておりませんが、自分のPC内でのテストはうまくいきました。ありがとうございました。

その他の回答 (3)

回答No.4

追伸、 前言撤回 >ネットワークドライブでは /s 無効 Win7からNAS(Linuxサーバー)     WinXP・Win7の共有フォルダ なら有効でした。検証が不十分でした、すみません。 Win10だとNAS(Linuxサーバー)はスムースに出来ましたが Win10 ⇔ WinXP共有フォルダ・Win7共有フォルダだと な~んか変です。 /s が効かない場合がある・反応が鈍い・パスワードを再度要求される場合。 Win10は仮想環境下でテスト中です。実際に使っているわけではありません。 私の環境設定がマズイのかも? 普段使いのサブフォルダも含めたファイル処理(検索など)は 私も同様にScripting.FilesystemObjectを利用している場合が多いです。 ただ、C:\直下からすべてのサブフォルダを検索する場合など (通常やりませんが「遊び」でやる・・) アクセス権やUAC関連起因のエラー処理を入れておかないと×です。 以上、既回答のも含めてご参考までに。

emaxemax
質問者

お礼

追加の質問にもお答えくださいましてありがとうございます。 いま、Windows7、Excel10で、共有サーバー内を検索してみました。 だいじょうぶでした。 ただ、残念ながらまだ自分で理解できないのでこれを実装できまねん。ごめんなさい。

回答No.3

追伸、 >リンク先に□□されて □に『刺激』を入れてください。 リンク先の方と私は無縁です。 失礼しました。 追伸2、 コマンドプロンプトの、|clip はWindows7 Pro では使えますが、XPではClip.exeはないので不可。 Vistaは不明。 Windows10 Pro & Excel2016(32bit) でも動作確認できましたが Home エディションで、|clip が使用できるかは不明です。

emaxemax
質問者

お礼

ありがとうございます。

回答No.2

realbeatinさんのリンク先にされて、あまのじゃっきー弐(へそまがりー)です。 何かの時に役に立つかも? Sub test()   Const hideWindow As Integer = 0   Const bWaitOnReturn As Boolean = True   Dim sCMD As String   Dim oWS As Object   Dim V As Variant, V1 As String, sT As String   Dim i As Long, j As Long      Set oWS = CreateObject("Wscript.Shell")      sCMD = "dir /s /b /a-d " '/a-d でフォルダ除外、ネットワークドライブでは /s 無効   sCMD = sCMD & "d:\" 'ここをFiledaialogから      oWS.Run "%ComSpec% /c " & sCMD & "|clip", hideWindow, bWaitOnReturn '|clipでクリップボードへ      V1 = GetObject("\", "htmlfile").ParentWindow.ClipboardData.GetData("text")   V = Split(V1, vbCrLf)   For i = 0 To UBound(V)     sT = Right(V(i), Len(V(i)) - InStrRev(V(i), ".")) '拡張子部分     If sT Like "xls*" Then 'sT = "xls" Or sT = "xlsx" Then       j = j + 1       Debug.Print j, i, V(i) 'イミディエイトウィンドウへ確認出力、Book処理をここへ     End If   Next   Set oWS = Nothing End Sub

emaxemax
質問者

お礼

ありがとうございます。 再帰処理なしでも可能なんですね。この方法でもできました。 ただ、わたしには高度すぎてなぜできるのか理解できていません。 (コマンドプロンプトって使ったことがありませんので・・・) でもこれがわかったらいろいろ使えそうですね。 ありがとうございました。

emaxemax
質問者

補足

> ネットワークドライブでは /s 無効 実際に使うのはネットワークドライブでつながっているサーバー内の特定のフォルダ(下に2階層あります)です。 その場合はどうなるのでしょうか?

関連するQ&A

専門家に質問してみよう