Excel VBA ExecuteExcel4Macroについて

質問

こんにちは。よろしくお願いします。
あるフォルダ"D:\test"のなかに、４つのxlsファイル"o.xls"、"a.xls"、"b.xls"、"c.xls"があるとします。
使用するシート名は、それぞれo,a,b,c（ファイル名から".xls"を除いたもの）とします。
このとき"o.xls"を開いて、下記のマクロを実行すると、１行目にパス名、２行名にファイル名、３行目以下に（１列目は"a.xls"の、２列目は"b.xls"の、３列目は"c.xls"の）セルA3以下が読み込まれます。
たとえば、結果は添付の図のようになります。図がうまくアップできなかったらごめんなさい。

Sub sample1()
Application.Calculation = xlManual
Application.ScreenUpdating = False
Application.DisplayAlerts = False
On Error Resume Next
Worksheets("o").Cells.Clear
Dim p As String, fn As String, fc As Long, i As Long, j As Long, d, e
p = ActiveWorkbook.Path
fn = Dir(p & "\" & "*.xls", 0)
fc = 0

If fn <> "" Then
fc = fc + 1
For j = 3 To 6
With Worksheets("o")
.Cells(1, fc).Value = p & "\" & fn
.Cells(2, fc).Value = fn
d = ExecuteExcel4Macro("'" & p & "\[" & fn & "]" & Mid(fn, 1, Len(fn) - 4) & "'!R" & j & "C1")
If d = 0 Or IsError(d) Then
Exit For
Else
.Cells(j, fc) = d
End If
End With
Next j
End If

Do
fn = Dir()
If fn <> "" Then
fc = fc + 1
For i = 3 To 6
With Worksheets("o")
.Cells(1, fc).Value = p & "\" & fn
.Cells(2, fc).Value = fn
e = ExecuteExcel4Macro("'" & p & "\[" & fn & "]" & Mid(fn, 1, Len(fn) - 4) & "'!R" & i & "C1")
If e = 0 Or IsError(d) Then
Exit For
Else
.Cells(i, fc) = e
End If
End With
Next i
Else
Exit Do
End If
Loop
Application.ScreenUpdating = True
Application.DisplayAlerts = True
Application.Calculation = xlAutomatic
End Sub

上記の例は変数iとjが3から6までしか動きませんし、読み込むxlsファイルも３つしかありませんのですぐに終わりますが、実際には行やファイルがもっとたくさんあり、非常に時間がかかっています。そこで、

ExecuteExcel4Macro("'" & p & "\[" & fn & "]" & Mid(fn, 1, Len(fn) - 4) & "'!R" & i & "C1")

を

e = ExecuteExcel4Macro("'" & p & "\[" & fn & "]" & Mid(fn, 1, Len(fn) - 4) & "'!R3C1:R6C1")

というような風にして、For～Nextも使用せず

.range(Cells(3, fc),cells(6, fc)) = e

というふうに範囲で読み込もうとしたのですがうまくいきません。
ExecuteExcel4Macroは範囲を読み込むことはできないのでしょうか？
何とかして処理速度を上げたいのですが、どうすればよいでしょうか。

回答No.3

Wendy02 · ベストアンサー

こんにちは。

mitarashiさん、どうもありがとうございます。
今回の件については、私のコードは苦肉の策の内容のようです。

>ExecuteExcel4Macroは範囲を読み込むことはできないのでしょうか？

今回のコードも、INDEX関数で取ることはできないわけではないのですが、本質的には、一つずつ取り出すしかないようですね。

なお、ExecuteExcel4Macroを使うと、使うメリットは、ファイルを開かなくて済むということですが、DAOやADOの方法もあります。開くときのオーバーヘッドが減らせますから、ファイルの数が多ければ多いほど、時間は少なくて済むはすだと思います。

以下のコードは、値自体のエラー値や'0'を取り去ることも出来ませんが、同じ技法を使った、Consolidate という方法があります。少しは、速くなるような気がします。

なお、以下のコードの細かい点は検証されていません。
'-------------------------------------------

Sub TestMacro1()
　　Dim p As String
　　Dim fn As String
　　Dim j As Long
　　Const EXT As String = ".xls"　'拡張子
　　Application.Calculation = xlManual
　　Application.ScreenUpdating = False
　　Application.DisplayAlerts = False

　　p = Application.DefaultFilePath

　　With Worksheets("o")
　　　　.UsedRange.Clear
　　　　fn = Dir(p & "\" & "*.xls", vbNormal)

　　　　Do
　　　　　　.Cells(1, j + 1).Value = p & "\" & fn
　　　　　　.Cells(2, j + 1).Value = fn

　　　　　　.Range("A3").Resize(4).Offset(, j).Consolidate Sources:= _
　　　　　　"'" & p & "\[" & fn & "]" & Replace(fn, EXT, "", 1) & "'!R3C1:R6C1", _
　　　　　　Function:=xlSum, TopRow:=True, LeftColumn:=False, CreateLinks:=False
　　　　　　j = j + 1
　　　　　　fn = Dir()
　　　　Loop While Dir() <> ""
　　End With
　　Application.ScreenUpdating = True
　　Application.DisplayAlerts = True
　　Application.Calculation = xlAutomatic
End Sub

お礼

Wendy02さん
いつもありがとうございます。
mitarashiさんのご回答をいただいてから、「一旦配列に受けておいて、一気にセルに代入する」ためにいろいろ苦心していましたが、ついには捗のいかないまま、Wendy02さんのコードを拝借させていただく仕儀となりました。
実行結果についてひとつ申し添えますと、

　　　　Loop While Dir() <> ""

のところは

Loop Until fn = ""

にさせていただきました。
もちろん"o.xls"の情報をもういちどD列に書き出す必要などないのですが、前者のままだとなぜか"c.xls"のデータが読み込まれなかったからです。
とにかく、大変感謝しております。ありがとうございました。

回答No.2

mitarashi

範囲で読み込んでいる例を見たことがないので、出来ないのかもしれません。（確証なし）
下記に、本板の常連のWendy02さんの回答例があります。
http://oshiete1.goo.ne.jp/qa2999291.html
試してみた結果では、一旦variant型の配列に値を収納しておいて、範囲に代入するところが高速化に効いている様でした。
データ数が増えてくると、ご呈示のコードの
.Cells(i, fc) = e
のところを、一旦配列に受けておいて、一気にセルに代入するのは高速化に相当効きます。（5年くらい前のCeleron機で、1000個のデータ読込・転写が6.6秒位でしたが、どうでしょうか）
http://officetanaka.net/excel/vba/speed/s11.htm

回答No.1

rivoisu

最後の方の
.range(Cells(3, fc),cells(6, fc)) = e
は
e=.range(Cells(3, fc),cells(6, fc)) の間違いでしょうか？
eをvariantにしてはいかがですか
ExecuteExcel4Macroをなぜ使わなければならないのかよく解りません
＞セルA3以下が読み込まれます。
とあるので単なる転記(代入）でいいと思いますが。