• ベストアンサー
  • 困ってます

エクセルVBAでBOOKに読み取りパスワード設定

エクセル2013です。 以下のコードで指定した任意のフォルダ内のエクセルに読み取りパスワードを設定できました。 しかし、そのフォルダの下にサブフォルダーがあった場合にサブフォルダ内のBOOKは対象になりません。どのように直せばサブフォルダも対象にできるようになるでしょうか?教えてください。 Sub TEST01()   Dim myfdr As String, fname As String   Dim mb As Workbook, wb As Workbook   Dim n As Long   With Application.FileDialog(msoFileDialogFolderPicker) '対象とするフォルダの指定      If .Show = True Then       myfdr = .SelectedItems(1)     Else       MsgBox "キャンセルします。"       Exit Sub     End If   End With   Set mb = ThisWorkbook 'このコピー先ブックをmbとする。   fname = Dir(myfdr & "\*.xls*") 'フォルダ内のExcelブックを検索   n = 2   Do Until fname = Empty '全て検索     Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。     With mb.Sheets("Sheet1") '転記       .Cells(n, "B").Value = wb.FullName       .Cells(n, "C").Value = wb.Sheets(1).Range("B1").Value     End With     n = n + 1 'カウント     Application.DisplayAlerts = False     wb.SaveAs Filename:=wb.FullName, Password:="emaxemax"     wb.Close     Application.DisplayAlerts = True     fname = Dir 'フォルダ内の次のExcelブックを検索   Loop '繰り返す   MsgBox n - 2 & "件処理しましました。" End Sub

共感・応援の気持ちを伝えよう!

  • 回答数4
  • 閲覧数955
  • ありがとう数9

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

  • ベストアンサー
  • 回答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 大いに参考になることと思います。 以上です。

共感・感謝の気持ちを伝えよう!

質問者からのお礼

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

質問者からの補足

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

関連するQ&A

  • VBAでシート名を変える、グラフのリンクを切る等を教えてください

    以前、「複数ブックのシートを一つのブックにコピーする」VBAを教えていただきました。 そこで、誠に恐縮なのですが、下記を追加するにはどのようにすればよいのでしょうか? 1、コピー元とのグラフのリンクを解除する。    数式のリンクは解除されているので、恐らくグラフのリンクが解除されていない。毎回、編集→リンクの設定で解除している。 2、シート名をセルB2の5文字目以降にしたい。 3、1つのセルに255文字以上入力されている、以降の文字がコピーしない現象を回避。    シートのコピーをすると、255文字以降がコピーされない??    セルを範囲選択してコピーした場合は、コピーできる。 4、最後に「Sheet1」を削除 下記が現在のVBAです。 Sub Consolid03() Dim mb As Workbook, wb As Workbook Dim myfdr As String, fname As String, n As Integer Application.ScreenUpdating = False '画面更新を一時停止 Set mb = ThisWorkbook 'このコピー先ブックをmbとする。 myfdr = ThisWorkbook.Path fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索 Do Until fname = Empty '全て検索 If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。 wb.ActiveSheet.Copy After:=mb.Sheets(mb.Sheets.Count) '開いたシートをコピーしてmbの末尾に置く wb.Close (False) '有無を言わずに保存せず閉じる mb.Sheets(mb.Sheets.Count).Unprotect Password:="9" 'パスワード解除 For Each c In mb.Sheets(mb.Sheets.Count).UsedRange '取り込んだシートの使用範囲に If c.FormulaR1C1 Like "=*!*" Then '他シート参照があれば c.Value = c.Value '値に変更 End If Next mb.Sheets(mb.Sheets.Count).Protect Password:="9" 'パスワード保護 n = n + 1 'ブック数をカウント End If fname = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す Application.ScreenUpdating = True '画面更新一時停止を解除 MsgBox UCase(Environ("UserName")) & "さん、" & n & "件のブックをコピーしましました。" _ + Chr(&HD) + Chr(&HA) + "他シートを参照する式だけは値にしておきましたよ。" _ + Chr(&HD) + Chr(&HA) + "" _ + Chr(&HD) + Chr(&HA) + "取りこんだシートにパスワード保護もかけておきましたよ。", , "( ̄ー ̄)v " End Sub 以上、ご教示願います。。。

  • エクセルVBAで読み取りパスワード回避

    エクセル2010です。 以下のコードで任意のフォルダ内のエクセルBOOKから所定のデータを取得できます。 しかし、指定フォルダ内に読み取りパスワードが設定されたものがあると、開くことができずに止まってしまいます。 読み取りパスワードが同一で、事前に分かっていればコードにPassword:="AAAABBBB" などと書き入れればいいと思うのですが、事前にはわかりませんし、パスワードもそれぞれ異なります。 そこで、開けなかった場合には、そのBOOKを飛ばしてすすみ、別シートに飛ばしたBOOK名を記録しておきたいのです。 (BOOK作成者にあとからパスワードを聞くため) しかし、残念ながらどのように書けばいいのか思いつきません。 ご指導いただければ幸いです。 Sub TEST001()   Dim wb(1) As Workbook   Dim ws(1) As Worksheet   Dim myFdr As String, fn As String   Dim i As Long   With Application.FileDialog(msoFileDialogFolderPicker) 'フォルダ指定     If .Show = True Then        myFdr = .SelectedItems(1)     Else       Exit Sub     End If   End With   Application.ScreenUpdating = False '画面更新を一時停止   Set wb(0) = ThisWorkbook 'このコピー先ブックをwb(0)とする。   Set ws(0) = wb(0).Sheets(1) 'wb(0)の1枚目のシートをws(0)とする。   fn = Dir(myFdr & "\*.xls*") 'フォルダ内のExcelブックを検索   Do Until fn = Empty '全て検索     Application.EnableEvents = False     Set wb(1) = Workbooks.Open(myFdr & "\" & fn, UpdateLinks:=False, ReadOnly:=True) 'そのブックを開きwb(1)とする。     Set ws(1) = wb(1).Worksheets(1)     i = i + 1     ws(0).Cells(i, "A").Value = ws(1).Range("B2") 'ws(0)に転記     ws(0).Cells(i, "B").Value = wb(1).Name     ws(0).Cells(i, "C").Value = ws(1).Name     wb(1).Close (False) '保存せず閉じる     Application.EnableEvents = True     fn = Dir 'フォルダ内の次のExcelブックを検索   Loop '繰り返す   Application.ScreenUpdating = True '画面更新停止を解除   MsgBox i & "個取得" End Sub

  • VBAでBOOKを開かずにプロパティ変更

    エクセル2013です。 特定のフォルダ内のエクセルのBOOKのプロパティの作成者をすべて変えようと思います。 いろいろ試して、以下のコードでできるようになりました。 しかし、下記のコードではいちいちファイルを開かなくてはなりませんのでサイズが大きかったり、数が多いと結構時間がかかります。 手作業でファイルのプロパティを変えるときは、エクスプローラで右クリックすれば開かなくとも簡単にできます。VBAでもファイルを開かずにプロパティを変更するにはどうすればよいのでしょうか?お教えいただければ幸いです。 Sub TEST20190710()   Dim myFdr As String, fnm As String   Dim wb As Workbook   Dim n As Long   Const NEW_AUTHOR As String = "emaxemax"      Application.ScreenUpdating = False   Application.EnableEvents = False   myFdr = "C:\Users\User\Documents\TEST01"   fnm = Dir(myFdr & "\*.xls?")   Do Until fnm = Empty     Set wb = Workbooks.Open(myFdr & "\" & fnm)     Application.DisplayAlerts = False     wb.BuiltinDocumentProperties("Author").Value = NEW_AUTHOR     wb.Close SaveChanges:=True     Application.DisplayAlerts = True     n = n + 1     fnm = Dir   Loop   Application.ScreenUpdating = True   Application.EnableEvents = True   MsgBox n & "件のブックを処理しましました。", vbInformation End Sub

その他の回答 (3)

  • 回答No.4

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

共感・感謝の気持ちを伝えよう!

質問者からのお礼

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

  • 回答No.3

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

共感・感謝の気持ちを伝えよう!

質問者からのお礼

ありがとうございます。

  • 回答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

共感・感謝の気持ちを伝えよう!

質問者からのお礼

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

質問者からの補足

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

関連するQ&A

  • VBAにて複数フォルダのエクセルファイルからデータ抽出を行いたいのですが…

    現在、下記の方法で複数のブックからデータを抽出し、 一覧表示をしています。(一覧表示をしているブックを仮にAとします。) 今のままだと、同一フォルダ内のブックしか抽出されません。 これを、サブフォルダまで対象にするには、どうすれば良いのでしょうか? 簡単に例をあげると、 フォルダ(1)の中にAを入れておいて フォルダ(1)の下にあるサブフォルダ(1)、サブフォルダ(2)の中にあるブックからデータの抽出を行いたいのです。 現在つかっているVBAは Sub 抽出用() Dim FName As String Dim Folder As String Dim wb As Workbook Dim i As Integer, j As Integer Application.ScreenUpdating = False Folder = ThisWorkbook.Path & "\" i = 1: j = 1 Worksheets(1).Cells.ClearContents FName = Dir(Folder & "*.xls") Do While FName <> "" If FName <> ThisWorkbook.Name Then Workbooks.Open (Folder & FName) Workbooks(Workbooks.Count).Worksheets(5).Rows("1:1").Copy _ ThisWorkbook.Worksheets(5).Cells(i + 3, 1) Workbooks(Workbooks.Count).Close Application.StatusBar = j & "ファイル処理済み" i = i + 1: j = j + 1 End If FName = Dir() Loop Application.StatusBar = "" Application.ScreenUpdating = True MsgBox ("完了しました") End Sub です。 いいお知恵があれば、よろしくお願い致します。

  • 新しく開いたブックをアクティブにするマクロ

    マクロ 新しく作ったブックをアクティブにする マクロ初心者です。 マクロを使って同階層にあるファイルのアクティブのシートを ひとつのブックにコピーして保存するマクロを作りたいと思ってます。 他の質問を参照して下記のコードを途中まで作成しました。 参照した質問では、 マクロの入っているブックにシートをコピーするようでしたが、 そうすると保存した時にマクロも保存されてしまうので 私なりに調べて、新しいブックにシートコピーするようにしましたが、 この記述の後、新しいブックをアクティブにする記述がわからず、 保存できなくなってしまいました。 ここまで終わるとマクロの入っているブックがアクティブになって終わります。 このあと新しく開いたブックをアクティブにして、 ブックのsheet1~3を削除して、名前をつけて保存したいのですが 開いたブックをアクティブにするマクロをご伝授ください。 あたらしくブックをつくるとbook1~・・・と名前が変わってしまうので 変数で名づけたいのですが、やり方が良くわかりませんのでよろしくお願いします。 何卒よろしくお願いします。 Sub consolid_test() Dim shCnt As Integer Dim Wb As Workbook Dim i As Integer Dim sh As Worksheet Dim nSh As Worksheet Dim fName As String Dim ka As String Application.ScreenUpdating = False '画面更新を一時停止 Application.DisplayAlerts = False Set mb = Workbooks.Add '新しいコピー先ブックをmbとする。 myfdr = ThisWorkbook.Path fName = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索 Do Until fName = Empty '全て検索 If fName <> mb.Name Then 'ブック名がこのブックの名前でなければ Set Wb = Workbooks.Open(myfdr & "\" & fName) 'そのブックを開きwbとする。 Wb.ActiveSheet.Copy After:=mb.Sheets(mb.Sheets.Count) 'コピーしてコピー先ブックの末尾に置く ActiveSheet.Name = Range("B16") 'シート名の変更 ActiveSheet.Unprotect 'シート全体をコピーして値にする Cells.Select Selection.Copy Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False Wb.Close (False) '保存の有無を聞かずに保存しないで閉じる N = N + 1 'ブック数をカウント End If fName = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す ・ ・ ・ ・

  • 複数のエクセルファイルの統合について

    エクセルで複数のファイルを一つのファイルに統合したいのですが、 これまでExcel2007を使用していた時は、 OKWaveの過去の回答(質問:No.2186548)を参考に、 下記のマクロをコピーして実行できていたのですが、 Excel2010に更新してから試したところ、上手く実行できません。 Sub consolid() Application.ScreenUpdating = False '画面更新を一時停止 Set mb = ThisWorkbook myfdr = ThisWorkbook.Path fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelファイルを検索 Do Until fname = Empty '全て検索し終えると、fname = Empty となるので、その間以下を実行 If fname <> mb.Name Then 'ファイル名がこのファイルじゃなければ Set wb = Workbooks.Open(myfdr & "\" & fname) '選択したファイルを開く wb.Worksheets.Copy Before:=mb.Sheets(mb.Sheets.Count) 'コピーしてまとめ用ブック末尾に置く wb.Close '選択したファイルを閉じる n = n + 1 'ブック数をカウント End If fname = Dir '選択したフォルダ内の次のExcelファイルを検索します Loop '繰り返す Application.ScreenUpdating = True '画面更新一時停止を解除 MsgBox n & "件のブックをまとめましました。" End Sub 上から5行目の、『.xls』で引っかかっているのかなと、拡張子を『xlsx』に 変更してみましたが、統合処理が出来ませんでした。 上記マクロをどのように書き換えればよいか教えて頂けると助かります。 なお、OSはWindows7(64bit)です。

  • VBAのエラーで、セルの書式が多すぎるため書式を追加できません。

    Excel2003のVBAで質問です。 複数ブック→1つのブックで複数シート にするマクロを作成しています。 今まではうまく実行できていたのですが、 wb.Sheets("12月").Range("A1:AO45").Copy mb.Sheets(mb.Sheets.Count).Range("A1").Select mb.Sheets(mb.Sheets.Count).Paste を追加したところ、途中までは大丈夫なのですが、ある一定数以上のブックで 「セルの書式が多すぎるため書式を追加できません」とメッセージが出ます。 VBAのどの辺りを修正すればよいのでしょうか? また、都度 「コピーまたは移動先セルの内容を置き換えますか?」や「クリップボードにおおきな情報があります。この情報を貼り付けられるようにしますか?」などに「Y」や「N」を都度入力しなくてもよいようにできますでしょうか? 以上、よろしくお願いします。 下記は全マクロ。 Sub Consolid03() Dim mb As Workbook, wb As Workbook Dim myfdr As String, fname As String, n As Integer Application.ScreenUpdating = False '画面更新を一時停止 Set mb = ThisWorkbook 'このコピー先ブックをmbとする。 myfdr = ThisWorkbook.Path fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索 Do Until fname = Empty '全て検索 If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。 wb.Sheets("12月").Copy After:=mb.Sheets(mb.Sheets.Count) '開いたシートをコピーしてmbの末尾に置く wb.Sheets("12月").Range("A1:AO45").Copy mb.Sheets(mb.Sheets.Count).Range("A1").Select 'コピー先シートを選択してアクティブにする mb.Sheets(mb.Sheets.Count).Paste wb.Close (False) '有無を言わずに保存せず閉じる mb.Sheets(mb.Sheets.Count).Unprotect Password:="9" 'パスワード解除 For Each c In mb.Sheets(mb.Sheets.Count).UsedRange '取り込んだシートの使用範囲に If c.FormulaR1C1 Like "=*!*" Then '他シート参照があれば c.Value = c.Value '値に変更 End If Next n = n + 1 'ブック数をカウント End If fname = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す Application.ScreenUpdating = True '画面更新一時停止を解除 Dim ws As Worksheet '全てのシートの色をなしにする For Each ws In Worksheets ws.Tab.ColorIndex = xlColorIndexNone Next MsgBox UCase(Environ("UserName")) & "さん、" & n & "件のブックをコピーしましました。" _ + Chr(&HD) + Chr(&HA) + "他シートを参照する式だけは値にしておきましたよ。" _ + Chr(&HD) + Chr(&HA) + "" _ + Chr(&HD) + Chr(&HA) + "", , "( ̄ー ̄)v " End Sub

  • Excel マクロで複数ブックのデータを一つのブックにまとめる方法

    マクロ初心者です。 1つのフォルダの中に複数のbook(sheetも複数)があります。 これを新しい1つのbookにまとめたいです。 回答に下記マクロがありました。 Sub consolid() Application.ScreenUpdating = False '画面更新を一時停止 Set mb = ThisWorkbook 'このコピー先ブックをmbとする。 myfdr = ThisWorkbook.Path fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索 Do Until fname = Empty '全て検索 If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。 wb.Worksheets.Copy After:=mb.Sheets(mb.Sheets.Count) 'コピーしてコピー先ブックの末尾に置く wb.Close '開いたブックを閉じる n = n + 1 'ブック数をカウント End If fname = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す Application.ScreenUpdating = True '画面更新一時停止を解除 MsgBox n & "件のブックをコピーしましました。" End Sub これで使用した所マクロを実行する度に何度も同じシートが コピーされてしまいます。 できれば同じ名前のシートは上書きにしてマクロを何度も使用できるように【各BOOKは毎週更新されて私のフォルダに入ってきます】したいのですが そのような事は可能なのでしょうか? どなたか分かる方教えてください。お願い致します。

  • Excel マクロで複数ブックのデータを一つのブックにまとめる方法

    マクロ初心者です。 1つのフォルダの中に複数のbook(sheetも複数)があります。 これを新しい1つのbookにまとめたいです。 sheetは「bookを開いた時に表示されるsheetだけ」を新しいbookにまとめたいです。 どなたかの回答に下記マクロがありました。 Sub consolid() Application.ScreenUpdating = False '画面更新を一時停止 Set mb = ThisWorkbook 'このコピー先ブックをmbとする。 myfdr = ThisWorkbook.Path fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索 Do Until fname = Empty '全て検索 If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。 wb.Worksheets.Copy After:=mb.Sheets(mb.Sheets.Count) 'コピーしてコピー先ブックの末尾に置く wb.Close '開いたブックを閉じる n = n + 1 'ブック数をカウント End If fname = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す Application.ScreenUpdating = True '画面更新一時停止を解除 MsgBox n & "件のブックをコピーしましました。" End Sub 非常によかったのですが、これですと (1)全てのsheetがコピーされてしまいます。 (2)また、保存しますか?とbookごとに聞いてきます。 上記のマクロのどこを変更すれば、(1)(2)を解決できますでしょうか? (エクセルは2002です) 以上、よろしくお願いします。

  • 同一フォルダの複数ブックの値を取得マクロ

    エクセル2010のマクロで困っています。 同一フォルダ内・複数ブックの 「異動表」というシートの特定のセルを抽出し、一覧にするマクロを素人ながら作成しようとがんばっています。 下記、マクロを作成したのですが、 必ず、98件(98ブック)前後でマクロが止まってしまいます。 【Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。】←ここで止まります。 なぜなのでしょうか??ご教授願います。 Sub (1)() Dim mb As Workbook, wb As Workbook Dim myfdr As String, fname As String, n As Integer Application.ScreenUpdating = False '画面更新を一時停止 Set mb = ThisWorkbook 'このコピー先ブックをmbとする。 myfdr = ThisWorkbook.Path fname = Dir(myfdr & "\*.xlsx") 'フォルダ内のExcelブックを検索 Do Until fname = Empty '全て検索 If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。 wb.Sheets("異動表").Range("A1").Copy '選択&コピー mb.Sheets("Sheet1").Activate 'コピー先シートを選択してアクティブにする Range("a1048576").End(xlUp).Offset(1, 0).Activate 'データ最終行を選択 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False '形式を選択して貼付→値 wb.Sheets("異動表").Range("b1").Copy '選択&コピー mb.Sheets("Sheet1").Activate 'コピー先シートを選択してアクティブにする Range("b1048576").End(xlUp).Offset(1, 0).Activate 'データ最終行を選択 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False '形式を選択して貼付→値 wb.Sheets("異動表").Range("b4").Copy '選択&コピー mb.Sheets("Sheet1").Activate 'コピー先シートを選択してアクティブにする Range("c1048576").End(xlUp).Offset(1, 0).Activate 'データ最終行を選択 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False '形式を選択して貼付→値 wb.Sheets("異動表").Range("m2").Copy '選択&コピー mb.Sheets("Sheet1").Activate 'コピー先シートを選択してアクティブにする Range("d1048576").End(xlUp).Offset(1, 0).Activate 'データ最終行を選択 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False '形式を選択して貼付→値 wb.Sheets("退職金計算書").Range("d21").Copy '選択&コピー mb.Sheets("Sheet1").Activate 'コピー先シートを選択してアクティブにする Range("e1048576").End(xlUp).Offset(1, 0).Activate 'データ最終行を選択 Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _ :=False, Transpose:=False '形式を選択して貼付→値 Application.ScreenUpdating = True 'コピー先のセルの内容を置き換えますか?=YES Application.DisplayAlerts = False '警告表示を出さない Application.CutCopyMode = False 'クリップボードのコピーを消す wb.Close (False) '有無を言わずに保存せず閉じる For Each c In mb.Sheets(mb.Sheets.Count).UsedRange '取り込んだシートの使用範囲に If c.FormulaR1C1 Like "=*!*" Then '他シート参照があれば c.Value = c.Value '値に変更 End If Next n = n + 1 'ブック数をカウント End If fname = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す Application.ScreenUpdating = True '画面更新一時停止を解除 Dim ws As Worksheet '全てのシートの色をなしにする For Each ws In Worksheets ws.Tab.ColorIndex = xlColorIndexNone Next MsgBox UCase(Environ("UserName")) & "さん、" & n & "件のブックをコピーしましました。" _ + Chr(&HD) + Chr(&HA) + "他シートを参照する式だけは値にしておきましたよ。" _ + Chr(&HD) + Chr(&HA) + "" _ + Chr(&HD) + Chr(&HA) + "", , "( ̄ー ̄)v " End Sub

  • マクロで複数ブックのデータを一つのブックにコピー

    マクロ超初心者です。 1つのフォルダの中に複数のbook(sheetも複数)があります。 これを新しい1つのbookにまとめたいです。 sheetは「bookを開いた時に表示されるsheetだけ」を新しいbookにまとめたいです。 どなたかの回答に下記マクロがありました。 Sub consolid() Application.ScreenUpdating = False '画面更新を一時停止 Set mb = ThisWorkbook 'このコピー先ブックをmbとする。 myfdr = ThisWorkbook.Path fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索 Do Until fname = Empty '全て検索 If fname <> mb.Name Then 'ブック名がこのブックの名前でなければ Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。 wb.Worksheets.Copy After:=mb.Sheets(mb.Sheets.Count) 'コピーしてコピー先ブックの末尾に置く wb.Close '開いたブックを閉じる n = n + 1 'ブック数をカウント End If fname = Dir 'フォルダ内の次のExcelブックを検索 Loop '繰り返す Application.ScreenUpdating = True '画面更新一時停止を解除 MsgBox n & "件のブックをコピーしましました。" End Sub このマクロを使わせていただき、 これでいける!と思ったのですが、255文字以上のコピーが出来ません。 どのようにすればよいでしょうか?

  • 複数シートをブックにするマクロを応用して。。

    1ブック内にyymmdd(日付)シートが多数あり、それを月別yymmごとブックを作成するマクロです。 これは以前、回答して頂いた「n-jun」さんの構文です(n-junさん、重宝しています、感謝!) Private Sub CommandButton1_Click() Dim myDic As Object Dim wb1 As Workbook Dim wb As Workbook Dim ws As Worksheet Dim sh As Worksheet Dim myKey Set myDic = CreateObject("Scripting.Dictionary") Set wb1 = ThisWorkbook Application.ScreenUpdating = False For Each sh In wb1.Worksheets myDic(Left(sh.Name, 4) & "_") = Empty Next For Each myKey In myDic.keys For Each sh In wb1.Worksheets If InStr(sh.Name, Left(myKey, 4)) > 0 Then If wb Is Nothing Then wb1.Worksheets(sh.Name).Copy Set wb = ActiveWorkbook Else wb1.Worksheets(sh.Name).Copy after:=wb.Sheets(wb.Sheets.Count) End If End If Next Application.DisplayAlerts = False wb.SaveAs Filename:="C:\仕事\月別" & "\" & Left(myKey, 4) & ".xls" wb.Close Set wb = Nothing Application.DisplayAlerts = True Next Application.ScreenUpdating = True Set myDic = Nothing Worksheets("main").Activate MsgBox "出力完了" End Sub 実は、これをフォルダ内のブックの場合は? として応用ができないか悩んでいます。 つまり、フォルダ内にyymmddブックが多数あり、 これを月別yymmとして、それぞれまとめたいのです。 Set wb1 = ThisWorkbookの箇所が、 フォルダ内のブック指定になると思うのですが、 下記コードでどうなんでしょうか?動きません。 myfdr = "C:\仕事\月別" fname = Dir(myfdr & "\*.xls") 'フォルダ内のExcelブックを検索 Do Until fname = Empty '全て検索 Set wb1 = Workbooks.Open(myfdr & "\" & fname) 変更箇所、アドバイス頂ければ助かります。お願いします

  • エクセルVBAで、ある条件の時

    お世話になります。 エクセルVBAで次のようなことをしたいのですが方法を教えてください。 formフォルダにあるすべてのファイルについて、A1セルが「0」でないとき、 A4:B7及びA9:B12の中で日付が入っている行の日付と内容を、ActiveWorksheetのB列、C列にレコードとして取り出したいのです。 (A列はナンバリングになります) --------formフォルダの中にあるブック---------   A  B 1 23 2 3 日付 内容   'この行は固定です 4 5/13 あああ 5 5/17 いいい 6 7 8 日付 内容   'この行は固定です 9 5/16 ううう 10 5/12 えええ 11 12 5/10 おおお ---ThisWorkbook(前に助けていただいたコードです)--- Sub data_torikomi2()   Dim wb As Workbook   Dim Fn As String   Dim myPath As String   Dim dbBkSh As Worksheet   Dim i As Long   For Each wb In Workbooks     If wb.Name <> ThisWorkbook.Name And _     InStr(1, wb.FullName, "form\", 1) > 0 Then 'formを検索       wb.Close '閉じる     End If   Next wb   myPath = ThisWorkbook.Path & "\"   Set dbBkSh = ThisWorkbook.Worksheets("一覧表")          Range("4:1000").Clear '全データ削除   Fn = Dir(myPath & "form\*.xls")   i = 1   '画面のちらつきを抑える   Application.ScreenUpdating = False   Do Until Fn = ""     If Fn <> ThisWorkbook.Name Then       With Workbooks.Open(myPath & "form\" & Fn, , True)         dbBkSh.Range("A3").Offset(i, 0).Value = i     【★たぶんこの部分に入るものです★】         .Close False         i = i + 1      End With     End If     Fn = Dir()   Loop   Application.ScreenUpdating = True   Set dbBkSh = Nothing End Sub ご教示よろしくお願いします。