• ベストアンサー

再起処理について

お世話になっております。 VBA初心者です。 あるフォルダ以下にあるエクセルファイルに対しパスワードを一括変更するマクロを作成しております。 単一のフォルダに対し処理はできたのですが、配下全てとなると再起処理が必要なようで、いまいち理解できません。 そこで、どのようにしたら目的が果たせるかご教授いただけませんでしょうか。 以上、宜しくお願いいたします。 --------------------------単一のフォルダのソース Sub 同フォルダのみ() Dim myFilename Dim DR Dim MP Dim NP ' 各入力された値を変数にいれる ' (1)passwordがかかっているディレクトリ DR = Range("c4").Value ' (2)元からかかっているパスワード MP = Range("c8").Value ' (3)新しくつける読み込みパスワード NP = Range("c12").Value ' ファイル名 myFilename = Dir(DR & "\*.xls") ' ループ-------------------------ここから Do While myFilename <> "" ' エクセルファイルを開く Workbooks.Open Filename:=DR & "\" & myFilename, Password:=MP ' 新しいパスワード ActiveWorkbook.SaveAs Filename:=myFilename, Password:=NP ActiveWorkbook.Save Application.DisplayAlerts = False 'メッセージを出さない ActiveWorkbook.Close myFilename = Dir() Loop ' ここまで-------------------------ループ End Sub

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

  • ベストアンサー
  • redfox63
  • ベストアンサー率71% (1325/1856)
回答No.1

Dirを単独で使うのでしたら再帰処理には向いていません Dir処理中に新たにパスを与えたDir関数を使うと前の検索パスを破壊します Collectionオブジェクトと併用なら可能でしょう Dim Col as Collection Sub myfunc( sPath as String )   dim ss as string   ss = Dir( sPath )   do     if ss<>"" then       if ss<>"." and ss<>".." then         if GetAttr(ss) and vbDirectory then           ' 孫フォルダーまでは考えていない           col.Add(ss,ss)         else           ss = LcCse(ss)           if right( ss, 4) = ".xls" then             ' Excelファイルなら処理             call PasswordChange           end if         end if       end if       ss = Dir     end if   loop while ss<>"" end Sub Sub MainLoop   ' コレクションを初期化   col = new Collection   call myFunc( "C:\sample" )   if col.count then     dim n as integer     for n = 0 to col.count-1       call myFunc( col(n) )     next   end if End Sub 上記の例では c:\sample\fooやc:\sample\bar などC:\sampleのサブフォルダーまではうまく機能しますが C:\sample\foo\testなど 孫フォルダーなどがあると動作がおかしくなります

testAdmin
質問者

お礼

redfox63様 ご回答ありがとうございます。 Dirにこだわらないで、別の方の回答にあるようにFileSystemObjectを利用しようと思います。 ただ、ちょっと考え方が難しくよくわからないので もう少し考えてみようと思います。 ありがとうございました。

その他の回答 (1)

  • AKARI0418
  • ベストアンサー率67% (112/166)
回答No.2

http://hanatyan.sakura.ne.jp/index.html ファイルシステムオブジェクトを利用してみてください。 再起処理の例も載っていると思います。

testAdmin
質問者

お礼

AKARI0418様 ご回答ありがとうございます。 FileSystemObjectを使用してなんとか作り上げることができました。 ご教授ありがとうございました。

関連するQ&A

  • エクセルマクロ初心者です。教えてください。

    エクセルマクロ初心者です。 仕事で使うエクセルにマクロを本をまねたりウェブで調べたりして見よう見まねで組んでみました。 稟議書ナンバー(L1)をファイル名として別フォルダに保存してそのまま閉じるマクロを作成できたのですが、別フォルダに保存したときに一緒にマクロも保存されてしまいます。 マクロは保存せずに別フォルダに稟議書シートのみ保存したいのですがどのようにすればよいのでしょうか。 以下がファイル保存のマクロです。 Sub booksave() ' ' booksave Macro ' マクロ記録日 : 2009/3/30 ユーザー名 : ' ' Dim myFileName As String '稟議No. myFileName = Range("l1").Value '稟議No.を変数に取得する ChDir "F:\稟議書" Sheets("表").Copy ChDir "F:\稟議書\稟議書保存" ActiveWorkbook.SaveAs Filename:="F:\稟議書\稟議書保存\" & myFileName & ".xls", FileFormat:= _ xlNormal, Password:="", WriteResPassword:="", ReadOnlyRecommended:=False _ , CreateBackup:=False ActiveWorkbook.Close End Sub どうぞよろしくお願いいたします。

  • 「変更を保存しますか?」と聞かれたくない。

    現在のファイルと同名のCSVファイルを作成したいのですが、 Sub CSV作成() Dim MyFileName As String MyFileName = ActiveWorkbook.FullName MyFileName = Left(MyFileName, Len(MyFileName) - 5) Workbooks.Add ActiveWorkbook.SaveAs Filename:=MyFileName & ".csv", FileFormat:=xlCSV ActiveWorkbook.Save ActiveWindow.Close End Sub をしたときに、「変更を保存しますか?」と聞かれます。 保存しますか?と聞かれても、無条件で保存したいし、そもそも変更してないのに、 なんで聞かれてるのかわかりません。 保存する方法を教えてください。ご回答よろしくお願いします。

  • エクセルのマクロでファイル名変更

    Dim フォルダ パス = ActiveWorkbook.Path 本体 = ActiveWorkbook.Name 変更1 = Sheets(1).Range("B2") フォルダ = パス & "\" & 変更1 ' & "\" 拡張子 = Sheets(1).Range("B3") 語句1 = Sheets(1).Range("B5") 語句2 = Sheets(1).Range("C5") aa = 1 '7777777777 指定フォルダの書き出し 7777777777 Dim myFileName As String Sheets(1).Select Range("B7:B1000").Clear Range("D7:E1000").Clear 'Rows("2:10000").ClearContents '隠しファイルとシステムファイルも表示 myFileName = Dir(フォルダ & "\" & "*." & 拡張子, vbHidden + vbSystem) Sheets(1).Select While myFileName <> vbNullString Cells(Rows.Count, 2).End(xlUp).Offset(1).Value _ = myFileName myFileName = Dir() Wend 下端 = Range("B" & Rows.Count).End(xlUp).Row rrname = 1 For a = 7 To 下端 If rrname < 10 Then Cells(a, 4) = "第00" & rrname & "話" & Cells(a, 3) & "." & 拡張子 ElseIf rrname >= 10 Then Cells(a, 4) = "第0" & rrname & "話" & Cells(a, 3) & "." & 拡張子 ElseIf rrname >= 100 Then Cells(a, 4) = "第" & rrname & "話" & Cells(a, 3) & "." & 拡張子 End If rrname = rrname + 1 Next a For b = 7 To 下端 旧ファイル名 = Cells(b, 2).Value 新ファイル名 = Cells(b, 4).Value Name フォルダ & "\" & 旧ファイル名 As フォルダ & "\" & 新ファイル名 Next b でファイル名変更マクロを作成したのですが、『ファイル名または番号が不正です』とエラーが返ってきますが、何が悪いのでしょうか?

  • CreateObjectとGetObjectの違い

    当方エクセル2003です。 Sub test_CreateObject() Dim App As Excel.Application Dim MyFileName As String Set App = CreateObject("Excel.Application") MyFileName = ActiveWorkbook.Path & "\新規Microsoft Excel ワークシート.xls" With App .Workbooks.Open FileName:=MyFileName .Visible = True End With Set App = Nothing End Sub --------------------------------------------------------- Sub test_GetObject() Dim App As Excel.Application Dim MyFileName As String Set App = GetObject(, "Excel.Application") MyFileName = ActiveWorkbook.Path & "\新規Microsoft Excel ワークシート.xls" With App .Workbooks.Open FileName:=MyFileName .Visible = True End With Set App = Nothing End Sub この二つは何が違うのでしょうか? どちらも既存のエクセルファイルがが開きます。

  • フォルダの中のファイル数を取得するには vba

    手作業でフォルダのプロパティからファイルの数を確認することはできるのですが VBAで(FSOなど)、該当のフォルダの中に何個ファイルが入ってるかを確認するコードはありますか? Sub test() Dim MyFileName As String Dim MyFolderName As String Dim i As Long MyFolderName = "\○○\icon" MyFileName = Dir(MyFolderName & "\*.*") Do While MyFileName <> "" MyFileName = Dir() i = i + 1 Loop MsgBox i End Sub このようなコードを作ってみたのですが、 画像のように実際に目で確認したファイル数と一致しません。 正しい数が取得できるvbaコードはありますか?

  • Excelでの Dir

    excel VBAにて Dir関数を用いて、フォルダに存在するファイルを つかむのに、下記のスクリプトがあります。(渡辺ひかる氏のサンプル集)。 質問は、このスクリプトで引っ張り出されるファイルの順番です。本を色々調べたのですが、順番は、「不明」とあります。 しかし、現実は、アルファベット順? に並んでいるように思われます。 本当のところは、どうなんでしょう? 「不明」なのか、それとも「順番が成立している」のか? よろしくお願いします。 ---------------------------------------- Option Explicit Sub P_Sample003() Dim myPath As String Dim myFileName As String Dim i As Long myPath = ThisWorkbook.Path & "\" '任意のフォルダ myFileName = Dir(myPath, 0) Do While Len(myFileName) > 0 Debug.Print myPath & myFileName myFileName = Dir() Loop End Sub

  • vba ファイルの移動について

    フォルダAの中にあるたくさんのpdfファイルの中から、 ファイル名の頭文字3つがE列に記載した「aaa」だったら フォルダBに移動させるという内容にしたいです。 ネット検索などで、近いものを作成しましたが(下に貼り付け)、 下から4行目、「fso.moveFile FolderA & "\" & fileName, FolderB & "\" & fileName」で 「実行時エラー'53'  ファイルが見つかりません。」 とエラーが出てしまいます。 どの様に書き直せばよいのでしょうか? どなたかご存じでしたら、ぜひお教え下さい。 よろしくお願いします。 エクセル2010を使用しています。 Sub CheckAndMoveFiles() Dim FolderA As String Dim FolderB As String FolderA = Range("D1").Value FolderB = Range("B2").Value Dim fso As Object Set fso = CreateObject("Scripting.FileSystemObject") Dim ws As Worksheet Set ws = ActiveSheet Dim lastRow As Long lastRow = ws.Range("E" & Rows.Count).End(xlUp).Row Dim r As Long Dim fileName As String For r = 1 To lastRow If ws.Cells(r, "E").Value <> "" Then fileName = ws.Cells(r, "E").Value dFileName = Dir(FolderA & "\" & Left(fileName, 3) & "*.pdf") Do While dFileName <> "" dFileName = Dir() Loop fso.moveFile FolderA & "\" & fileName, FolderB & "\" & fileName 'ここでストップ End If Next End Sub

  • 複数のファイルの、複数のシートにあるD9セルの数字を、新しいブックにリ

    複数のファイルの、複数のシートにあるD9セルの数字を、新しいブックにリストしたいのですが、上手くいかないようです。 以下、それらしきマクロのコピペです。 (使用ソフトはエクセル2003です) Sub sample() Dim folder As String Dim sh As Worksheet Dim file As String Dim r As Long folder = "C:\abc\M1501~M2140\" 'ファイルがあるフォルダ sh.Range("A1").Value = "ファイル名" '見出し sh.Range("B1").Value = "A1" '同上 r = 2 '結果出力行の初期値 file = Dir(folder & "*.xls") 'フォルダ内の最初の.xlsファイルを取得 Do While file <> "" 'ファイル名がある間 Workbooks.Open folder & file 'そのファイルを開く sh.Range("A" & r).Value = file '結果シートのA列にファイル名を sh.Range("B" & r).Value = ActiveWorkbook.Sheets("あいうえお").Range("D9") '結果シートのB列に開いたブックのあいうえおのD9の値 ActiveWorkbook.Close False '開いたブックを閉じる r = r + 1 '結果出力行+1 file = Dir '次のファイル名取得 Loop '繰り返す End Sub これですと、「あいうえお」のシートのD9しか結果表示されないようです(実際、これは複数ファイルからの抽出用です)。 この式に複数シート対応の式を加えれば出来そうな気がするのですが、ここからどうすればいいかわかりません; 上記の式を大幅変更でも構いませんので、教えて下さい。

  • VBA 一つのフォルダの中のフォルダ名とファイル名

    一つのフォルダの中のフォルダ名とファイル名を取得したい場合は ************************************** Sub test() Dim MyFileName As String Dim MyFolderName As String Dim myFSO As Object Dim MyFolder As Scripting.Folder MyFolderName = "C:\" 'フォルダを取得 MyFileName = Dir(MyFolderName & "*.*") Do While MyFileName <> "" Debug.Print MyFileName MyFileName = Dir() Loop 'ファイルを取得 Set myFSO = CreateObject("Scripting.FileSystemObject") With myFSO With .GetFolder(MyFolderName) For Each MyFolder In .SubFolders Debug.Print MyFolder.Name Next End With End With Set myFSO = Nothing End Sub ************************************** の様に ファイル名・フォルダ名をそれぞれループして取得しないとダメでしょうか? もうちょっとスマートなコードはありますか?

  • VBAでフォルダにあるエクセルファイルを開く

    こんにちは このコードがうまく動かないのですが、 どこがいけないのかわからなく助けてください。 なおフォルダの中には******データ.xlsと言うファイルがあり、アスタリスク部分は日付が不規則に変化して上書きされるのです。 このファイルを開くマクロを作りたいのですが。 うまく行きません。 よろしくおねがいします。 Sub excelopen() ' ' Dim エクセル As String 'エクセル = Dir(ActiveWorkbook.Path & "\*データ.XLS") If エクセル = "" Then Exit Sub エクセル = ActiveWorkbook.Path & "\" & エクセル Workbooks.Open Filename:=エクセル End Sub