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

質問

エクセル２０１０のマクロで困っています。
同一フォルダ内・複数ブックの
「異動表」というシートの特定のセルを抽出し、一覧にするマクロを素人ながら作成しようとがんばっています。
下記、マクロを作成したのですが、
必ず、９８件（９８ブック）前後でマクロが止まってしまいます。

【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

回答No.3

MAXIMAX · ベストアンサー

#1 です。なんとも疑問ですが、ある程度処理すると、メモリが足りないとか起きていそうにも見えます。止まってしまうファイルを削除して実行してもやはり 98 件前後でとまりませんか？ただ、正直原因がわかりません・・・・・・。

-----
そこでちょっとソースコードを最適化してみてはどうだろう、と思いました。

セルをコピーするロジックですが、１セルだけなら選択や貼付けなどクリップボードを経由せずとも直接値を代入できます(範囲コピーだと、ちょっとコピー先の Range を指定する工夫がいりますが・・・・・・)。

こんな感じで。
Range("a1048576").End(xlUp).Offset(1, 0).Value = wb.Sheets("異動表").Range("b4").Value

それと、Close した後にある参照を値に変更しているロジック、これは必要なのでしょうか。別のブックからコピーしてくる際に常に "Sheet1" に "値" をコピーしているのですが、最後のシートに対して参照の置換えを行っていますが・・・・・・・。どこかで最後のシートに、なにか細工しているのでしょうかね。

直接のお役に立てなくてごめんなさい。

お礼

いろいろとありがとうございました。
ご指導いただいた通り簡素化したのですが、ダメでした。

どうやらエクセルのバグ？のようです。
http://excelfactory.net/excelboard/excelvba/excel.cgi?mode=all&namber=146940&rev=0

ですが、
VBAの画面から▸を押して実行すると、滞りなくマクロが動作することが
わかりました。

これで運用します。
ありがとうございました。

回答No.2

MAXIMAX

#1 です。まだ質問継続されていますでしょうか・・・・・・。

マクロが止まった際に、小さなウィンドウで「実行時エラー」というのが表示されてはいないのでしょうか？エラーが出ないままマクロが止まるというケースがちょっと想定できないのですが・・・・・・。
もし表示されていないようでしたら、Visual Basic の画面の下の方に「イミディエイト」というところがあると思うのですが、マクロが止まった際にそこに

? err.number & " : " & err.description

と入れてみてください。エラーが起きて止まっているのであれば、エラー番号とエラーメッセージが出るはずです。

-----
もう一つ、マクロが止まった際に Open しようとしていたファイルを、手動で Excel で開いてみて、他のファイルと変わらず特に普通に開けるか確認はしましたでしょうか？これもマクロが止まった際に、イミディエイトに

? fname

とすれば、開こうとしていたファイルがわかります(ウォッチに登録しておくのもいいですが)。

お礼

遅くなりまして申し訳ありません。

「実行時エラー」というウィンドウは出ておりません。

(1)イミディエイトに入力すると、下記が表示されます。

? err.number & " : " & err.description
1004 : 'Open' メソッドは失敗しました: 'Workbooks' オブジェクト

(2)? fname
で、開かなかったファイルは手動では開きます。

(3)さらに、わからないのが、
フォルダの中のうまく実行できたファイルを削除し、もう一度実行すると、最後まで実行できます。

回答No.1

MAXIMAX

close されているので同時に開き過ぎということもなさそうですよね。まずは止まったところでエラーメッセージが出ませんでしょうか？なんのエラーかがわからないと、解決策を探すのもちょっと大変です・・・・・・・。

お礼

ありがとうございます。
デバック画面で
【Set wb = Workbooks.Open(myfdr & "\" & fname) 'そのブックを開きwbとする。】
の部分が黄色ラインが引かれています。