同一フォルダの複数ブックの値を取得マクロ
エクセル２０１０のマクロで困っています。
同一フォルダ内・複数ブックの
「異動表」というシートの特定のセルを抽出し、一覧にするマクロを素人ながら作成しようとがんばっています。
下記、マクロを作成したのですが、
必ず、９８件（９８ブック）前後でマクロが止まってしまいます。
【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
お礼
回答ありがとうございました。 アドバイス通り、 fname = Dir(myfdr & "\*.xls*") で、無事にファイル統合できました。 以前、CSVファイルを統合したことがあって、 その時は、\*.csvへ書き換えることで統合できたのですが、 xlsxに書き換えても反応しなかったので、困っておりました。 試しに、CSVファイルの統合に、\*.csv*を使ってみた ところこちらも無事に統合できました。 無事解決できたため、ベストアンサーとさせて頂きます。