ExcelでBook毎の同一セルを抽出したい！！

質問

すみません困っています！！
Bookが９００以上ありますが，Book１～Book900までのひとつのセル（例えばB3）を抽出して，新しいBookに貼り付けるにはどうしたら良いでしょうか？？

何か良い方法はありませんか？

どなたかご教授願います．

回答No.4

WWolf

Ｄｒｐｈ＝ブックの入っているフルパス
ＩＴＩ＝セルの番地

Sub Test()
Dim fs, f, f1, fc, fn, s, sy, DrPh, ITI, Da
DrPh = "c:\"
ITI = "R1C1"
Set fs = CreateObject("Scripting.FileSystemObject")
Set f = fs.GetFolder(DrPh)
Set fc = f.Files
For Each f1 In fc
s = f1.Name
sy = Right(s, 3)
If sy = "xls" Then
q = " '" & DrPh & "\[" & s & "]sheet1'!" & ITI
Da = Application.ExecuteExcel4Macro(q)
MsgBox Da
End If
Next
End Sub

回答No.3

imogasi

Option Explicit
Sub GetFromFile()
Dim FileName, CellName, PathName, SheetName, arg As String
Dim result
Dim i As Long
i = 1
PathName = "C:\My Documents\"
FileName = Dir(PathName)
GoSub setdata
'------
Do
FileName = Dir()
If FileName <> "" Then
If Right(FileName, 4) = ".xls" Then
GoSub setdata
End If
End If
Loop While FileName <> ""
'-------
End
'==================
setdata:
SheetName = "Sheet1"
CellName = "A1"
arg = "'" & PathName & "[" & FileName & "]" & SheetName & "'!" & Range(CellName).Range("A1").Address(, , xlR1C1)
result = ExecuteExcel4Macro(arg)
Worksheets(1).Cells(i, 1).Value = result
i = i + 1
Return
End Sub
－－－－－－－－－－
ブック・シート保護がかかっていないこと。
ファイルを開かないで処理してます。先ほどから質問のあるExecuteExcel4Macroを使って見ました。
●PathName = "C:\My Documents\"を自分のケースに変えることと、この後は今問題にしているフォルダ名をいれ、フルパス名にすること。
テスト済み。

回答No.2

papayuka

ブック名がBook1,Book2のように規則性があり、シート名も同じで抽出したいセルも同じである。
上記のブックが全て集計したいブックと同じフォルダ内にある。
集計ブック名は命名規則と異なるものである。

上記に全て当てはまるなら、こんな感じのマクロでイケるのではと思います。

Sub Test()
For i = 1 To 900
　Range("A" & i).Value = _
　　　　"='" & ThisWorkbook.Path & _
　　　　"\[Book" & i & ".xls]Sheet1'!B3"
　Range("A" & i).Value = Range("A" & i).Value
Next i
End Sub

回答No.1

Mahk2

VBAのマクロ作ればそれほど難しくはないです。
フォルダ内の全ファイル（*.XLSに対して）をループして、各ファイルを開いて特定セルの内容を結果ワークシートに書き込むというのを繰り返せばOKですよ。
WORKBOOKを開かずにやると高速ですが、ちょっとプログラム的には面倒です^^;