複数のExcelBookの特定セルの取得

質問

Excel2003について教えてください。
複数の同じ内容のBookがあり、このBook内のあるシート内のセルの内容を集めて、別のブックにリストを作成したいのですが、別のコンピュータに複数のBookがあり、これを自分のマシンから参照するとすごく時間がかかります。
高速で取り込む方法はないでしょうか？
現在以下のVBAでやっています。
Sub リスト取得()
Dim eBookname As String 'Book名
Dim DrvDir As String 'ドライブフォルダ
Dim rw As Long '行カウンタ
Dim TargetCell0 As String '集計するセル
Dim TargetCell1 As String '集計するセル
Dim TargetCell2 As String '集計するセル
Dim TargetCell3 As String '集計するセル
TargetCell0 = "B4"
TargetCell1 = "C4"
TargetCell2 = "H4"
TargetCell3 = "I2"
DrvDir = ThisWorkbook.Path & "\" & "Working" & "\" '*** フォルダパスをセットします
With Worksheets("一覧")
.Range("C4:F65535").ClearContents '表示用のC~F列をクリア
rw = 3
'フォルダを検索してxlsファイルを特定する
eBookname = Dir(DrvDir & "*.xls")
Application.Calculation = xlCalculationManual
While eBookname <> ""
'順にSheet1に書き出していく
rw = rw + 1
.Range("C" & rw) = "='" & DrvDir & "[" & eBookname & "]ワーク'!" & TargetCell0
.Range("D" & rw) = "='" & DrvDir & "[" & eBookname & "]ワーク'!" & TargetCell1
.Range("E" & rw) = "='" & DrvDir & "[" & eBookname & "]ワーク'!" & TargetCell2
.Range("F" & rw) = "='" & DrvDir & "[" & eBookname & "]ワーク'!" & TargetCell3
eBookname = Dir
Wend
End With
Application.Calculation = xlCalculationAutomatic
MsgBox "リストを更新しました。" & vbCrLf & vbCrLf & "取得件数 " & rw - 3 & " 件です。", vbInformation, ""
End Sub

回答No.2

end-u · ベストアンサー

リンク式で引っぱってくるのは結構速いほうだと思うので、
>別のコンピュータに複数のBookがあり
というのがそもそものネックのような気もしますね。

ですが取りあえず、ScreenUpdating と EnableEvents プロパティも制御する事と、
配列を使ってまとめて書き込むようにしたら少しは変わるかも。

Sub try()
　　Const TargetCell0 As String = "B4" '集計するセル
　　Const TargetCell1 As String = "C4" '集計するセル
　　Const TargetCell2 As String = "H4" '集計するセル
　　Const TargetCell3 As String = "I2" '集計するセル
　　Dim eBookname As String　　　　　　'Book名
　　Dim DrvDir　　As String　　　　　　'ドライブフォルダ
　　Dim sFormula　As String　　　　　　'共通文字
　　Dim rw　　　　As Long　　　　　　　'行カウンタ
　　Dim x(1 To 65531, 1 To 4)　　　　　'式文字列格納用配列

　　'*** フォルダパスをセットします
　　DrvDir = ThisWorkbook.Path & "\" & "Working" & "\"
　　With Application
　　　　.ScreenUpdating = False
　　　　.EnableEvents = False
　　　　.Calculation = xlCalculationManual
　　End With
　　With Worksheets("一覧")
　　　　'表示用のC~F列をクリア
　　　　.Range("C4:F65535").ClearContents
　　　　'フォルダを検索してxlsファイルを特定する
　　　　eBookname = Dir(DrvDir & "*.xls")
　　　　While eBookname <> ""
　　　　　　rw = rw + 1
　　　　　　sFormula = "='" & DrvDir & "[" & eBookname & "]ワーク'!"
　　　　　　x(rw, 1) = sFormula & TargetCell0
　　　　　　x(rw, 2) = sFormula & TargetCell1
　　　　　　x(rw, 3) = sFormula & TargetCell2
　　　　　　x(rw, 4) = sFormula & TargetCell3
　　　　　　eBookname = Dir
　　　　Wend
　　　　.Range("C4:F4").Resize(rw).Formula = x
　　End With
　　With Application
　　　　.ScreenUpdating = True
　　　　.EnableEvents = True
　　　　.Calculation = xlCalculationAutomatic
　　End With
　　MsgBox "リストを更新しました。" & vbCrLf & vbCrLf & "取得件数 " & rw & " 件です。", vbInformation, ""
End Sub

回答No.1

n-jun

>別のコンピュータに複数のBookがあり、これを自分のマシンから
>参照するとすごく時間がかかります。
自分のPCにブックをコピーしてからではダメなのですか？