エクセルVBAでのエラー

質問

おはようございます。
昨日ここでいろいろ教えていただき、300のエクセルファイルから特定の範囲のデータ抽出方法を書いてみたのですが、セルが多すぎて実行できません、というエラーがでてしまいます。
これはどのように解消すればよろしいのでしょうか？

Sub Test()
Dim FPath1 As String, FPath2 As String
Dim FName As String, myBook As String
Const startROW As Long = 14, lastROW As Long = 20
Const startCOL As Long = 8, lastCOL As Long = 10
Const shtNAME As String = "sheet1"
Application.ScreenUpdating = False
FPath1 = "D:\MR5567\"
FPath2 = "D:\New Microsoft Excel Worksheet\"
Workbooks.Add
myBook = ActiveWorkbook.Name
FName = Dir$(FPath1 & "*.xls")
Do While FName <> ""
Workbooks.Open Filename:=FPath1 & FName
ActiveWorkbook.Sheets.Select
Sheets(1).Activate
Sheets.Copy After:=Workbooks(myBook).Sheets(Sheets.Count)
Workbooks(FName).Activate
Application.DisplayAlerts = False
ActiveWorkbook.Close
FName = Dir$
Loop
ActiveWorkbook.SaveAs Filename:=FPath2 & "Renketsu.xls", FileFormat:=xlNormal
ActiveWorkbook.Close
Application.ScreenUpdating = True
End Sub

回答No.2

zap35 · ベストアンサー

昨日のマクロを特定フォルダの全エクセルファイルに対して実行するならこんな感じですね。

ExecuteExcel4MacroのほうがOPENメソッドよりファイルを開かないだけ早いと思います。

Sub 他ブック参照２()
Dim idxR, idxC, pos, ofROW, ofCOL As Integer
Dim curROW, curCOL As Long
Dim wkSTR1, wkSTR2, wkSTR3, buf As String
Const startROW As Long = 14, lastROW As Long = 20 '行範囲を指定
Const startCOL As Long = 8, lastCOL As Long = 10 '列範囲を指定。H:8、J:10
Const shtNAME As String = "Sheet1" 'シート名は固定。ここで指定する
curROW = 1
wkSTR1 = "D:\MR5567\"
buf = Dir(wkSTR1 & "*.xls")
Do While buf <> ""
ActiveSheet.Cells(curROW, 1).Select
ActiveCell.Value = buf
ofROW = 1
ofCOL = 1
For idxC = startCOL To lastCOL
For idxR = startROW To lastROW
wkSTR3 = "'" & wkSTR1 & "[" & buf & "]" & shtNAME & "'!R" & idxR & "C" & idxC
Selection.Cells(1, 1).Offset(ofROW, ofCOL) = ExecuteExcel4Macro(wkSTR3)
ofROW = ofROW + 1
Next idxR
ofROW = 1
ofCOL = ofCOL + 1
Next idxC
curROW = Range("b65536").End(xlUp).Row + 1
buf = Dir()
Loop
End Sub

お礼

ありがとうございました。
お蔭様で無事解決いたしました。
ExecuteExcel4Macroは初めて使いました。
また勉強しなきゃですね。

回答No.1

Wendy02

こんにちは。

コードを読ませていただきました。7行のコピーだから、ひとつのシートにまとめてしまえばよいのでは？　7*300 = 2,100行ですから、そんなに数があるわけではありません。

シートを1,000もしくは、それ以上も増やすのは、物理的に無理だと思います。

前の質問で、早々締めないで、もう少し粘ったほうが良かったですね。回答者の方も、そういう回答だけしかなくて、回答したわけではないので、そちらで解決できたかもしれません。

以下は、元のコードに手を入れてみました。十分テストされているわけではありませんので、ある程度テストをしてから行ってください。特に、今は、ファイルのオープンのエラーは、こちらではありませんので、想像の範囲の中で書いています。エラーが発生した場合は、コピーされたブックは開いたままになります。セル自体のエラーは、コピーされます。

'------------------------------------------------------------------
Sub Test2()
　Dim FPath1 As String, FPath2 As String
　Dim FName As String, myBook As String
　Dim sh As Worksheet
　Dim DataBook As Workbook
　Dim i As Integer

　Const startROW As Long = 14, lastROW As Long = 20
　Const startCOL As Long = 8, lastCOL As Long = 10
　Const shtNAME As String = "Sheet1" '書き込み用シート'
ただし、既存のSheet1.. という名前しかできません。

　Application.ScreenUpdating = False

　FPath1 = "D:\MR5567\"
　FPath2 = "D:\New Microsoft Excel Worksheet\"

　Set DataBook = Workbooks.Add

　FName = Dir(FPath1 & "*.xls")

　i = 1 'コピー先初期行
　Do While FName <> ""
　　On Error GoTo ErrHandler
　　If FName <> ThisWorkbook.Name Then
　　With Workbooks.Open(Filename:=FPath1 & FName)

　　　For Each sh In .Sheets
　　　　With sh
　　　　If WorksheetFunction. _
　　　　　 CountA(.Range(.Cells(startROW, startCOL), .Cells(lastROW, lastCOL))) > 0 Then
　　　　　.Range(.Cells(startROW, startCOL), .Cells(lastROW, lastCOL)).Copy _
　　　　　 DataBook.Worksheets(shtNAME).Cells(i, 1)

　　　　　 i = i + (lastROW - startROW + 1)　'次の行の準備
　　　　End If
　　　　End With

　　　Next sh
　　　.Close False
　　End With
　　FName = Dir()
　　End If
　Loop

　DataBook.SaveAs _
　Filename:=FPath2 & "Renketsu.xls", FileFormat:=xlNormal
　DataBook.Close
ErrHandler:
　If Err.Number > 0 Then
　　 MsgBox FName & "で、トラブルが発生しました。マクロを終了します。" & vbCrLf & _
　　　Err.Number & ": " & Err.Description, vbExclamation
　Else
　　 MsgBox "正常に終了しました。", vbInformation
　End If

　Set DataBook = Nothing
　Application.ScreenUpdating = True
End Sub
'------------------------------------------------------------------

お礼

ありがとうございました。
あまりＶＢは得意ではないので、アドバイスいただき助かりました。