excel 他ブックからセルを範囲で取得する方法

質問

Ａbook.xlsx、B1book.xlsx、B2book.xlsx、B3book.xlsxというファイルがあります。
B1book~B3bookは同じフォーマットになりますが、Bbookのセル範囲（A1：C7）を
Ａbookの「集計シート」にセットしたいのですが、コードでの記述をご教授
頂けませんでしょうか。

Ａbookのイメージ
　　　A　　　　　　B　・・・・・・H
　1　B1book.xlsx　　A1・・・・・・A7
　2　　　　　　　　 B1・・・・・・B7
　3　　　　　　　　 C1・・・・・・C7
　4　B2book.xlsx　　A1・・・・・・A7
　5　　　　　　　　 B1・・・・・・B7
　6　　　　　　　　 C1・・・・・・C7
　7　B3book.xlsx　　A1・・・・・・A7
　8　　　　　　　　 B1・・・・・・B7
　9　　　　　　　　 C1・・・・・・C8
このようなイメージになります。
よろしくお願いします。

回答No.4

nishi6 · ベストアンサー

＞B1～B3を開かずにできたらと思っていたのですが、可能でしょうか。
bkPath にBブックの場所を指定してください。

Sub BookCopy2()
　Dim f As Integer

　Application.ScreenUpdating = False
　For f = 1 To 3
　　Call BookCopuSub2(f)
　Next
　Range("A1").Select
　Application.ScreenUpdating = True
End Sub

　Sub BookCopuSub2(f As Integer)
　　Const bkPath = "N:\*******\"　'// Bブックの場所を指定
　　Dim bkName As String
　　bkName = "B" & f & "book.xlsx"

　　Workbooks.Open bkPath & bkName
　　Sheets("Sheet1").Select
　　Range("A1:C7").Select
　　Selection.Copy

　　Windows("ABook2.xlsm").Activate
　　With Range("A1")
　　　.Offset((f - 1) * 3, 0) = "B" & f & "book.xlsx"
　　　.Offset((f - 1) * 3, 1).Select
　　　Selection.PasteSpecial Paste:=xlPasteAll, _
　　　　　Operation:=xlNone, SkipBlanks:= _
　　　　　False, Transpose:=True
　　End With

　　Application.DisplayAlerts = False
　　Workbooks(bkName).Close
　　Application.DisplayAlerts = True
　End Sub

お礼

早々にご回答頂き、ありがとうございます。
早速やってみようと思います。
本当にありがとうございました。

回答No.3

Mathmi

＞他ブックからセルを範囲で取得する方法
セルの表記をブックから正確に記述すると
　Workbooks(ブック名).Worksheets(シート名).Range(セル範囲)
になります。

なので、既に開いている[B1book.xlsx]ブックの[Sheet1]シートの[A1:C7]セル範囲は
　Workbooks("B1book.xlsx").Worksheets("Sheet1").Range("A1:C7")
で取得できます。
（開いていないブックのデータを取得するのは、どのフォルダに存在するファイルか、から指定しないといけないので、難易度が結構上がります）

これが分かっていれば、後は力業でも何とかできます。

・作業するブックは全て開いている。
・コピーするセル、貼り付けるセルは全てSheet1である。
・セル自体をコピーする（値だけでなく、文字色等の書式も含める）。
という前提で組んでみました。
値だけをコピーしたい場合は、コピー部分のコメントアウトを切り替えて下さい。

Sub CopyOtherBooks()
　Dim i As Long
　Dim myBK As Workbook 'ループ用
　Dim aryBooks As Variant 'データを取得するブック名。
　Dim rangeCopy As Range 'コピーするセル範囲
　Dim cellPaste As Range '貼り付ける基準セル。

　'コピーするブック名一式を設定
　aryBooks = Array("B1Book.xlsx", "B2Book.xlsx", "B3Book.xlsx")
　'貼り付ける範囲の左上のセルを設定。
　Set cellPaste = Workbooks("ABook.xlsm").Worksheets("Sheet1").Range("A1")

　For Each myBK In Workbooks
　　For i = LBound(aryBooks) To UBound(aryBooks)
　　　If myBK.Name = aryBooks(i) Then
　　　　'そのブックのコピーする範囲を設定。
　　　　Set rangeCopy = myBK.Worksheets("Sheet1").Range("A1:C7")
　　　　'貼り付け。
　　　　rangeCopy.Copy cellPaste
'　　　　'値だけを貼り付け
'　　　　cellPaste.Resize(rangeCopy.Rows.Count, rangeCopy.Columns.Count).Value = rangeCopy.Value
　　　　'貼り付ける範囲を下にずらす。
　　　　Set cellPaste = cellPaste.Offset(rangeCopy.Rows.Count, 0)
　　　End If
　　Next i
　Next myBK
End Sub

お礼

丁寧に記述頂きありがとうございます。
コメントも入れて頂き非常に分かりやすく助かります。
この方法でも試してみようかと思います。
本当にありがとうございました。

回答No.2

nishi6

B1book～B3bookの３ブックは開いているものとして書いています。また、いずれもSheet1にあるとしています。
閉じている前提ならば補足してください。修正します。
ブック名やセル範囲は質問にあるとおりにしています。

Ａbook.xlsxはマクロを含むので、Ａbook.xlsmになります。
当方、Win10、Excel2010です。

Sub BookCopy()
　Dim f As Integer
　For f = 1 To 3
　　Call BookCopuSub(f)
　Next
　Range("A1").Select
End Sub

　Sub BookCopuSub(f As Integer)
　　　Windows("B" & f & "book.xlsx").Activate
　　　Sheets("Sheet1").Select
　　　Range("A1:C7").Select
　　　Selection.Copy

　　　Windows("ABook.xlsm").Activate
　　　With Range("A1")
　　　　.Offset((f - 1) * 3, 0) = "B" & f & "book.xlsx"
　　　　.Offset((f - 1) * 3, 1).Select
　　　　Selection.PasteSpecial Paste:=xlPasteAll, _
　　　　　　Operation:=xlNone, SkipBlanks:= _
　　　　　　False, Transpose:=True
　　　End With
　End Sub

補足

丁寧に回答頂き本当にありがとうございます。大変助かります。
B1～B3を開かずにできたらと思っていたのですが、可能でしょうか。
もしお時間があればご教授頂けませんでしょうか。
よろしくお願いします。

回答No.1

imogasi

質問の説明が、ぴんと来なくて、課題がよくわからない。
シート画像でも張り付けては、どうだろう。
個別のセルの値を記述しても、イメージがわきにくいし、値そのものは、処理に
関係ないだろう。書き方が質問者の我流でわかりにくい。
ーー
まず思ったのは、必要なスキルは
・コピー貼り付けをすればよい。
・ＣｕｒｒｅｎｔＲｅｇｉｏｎが使えないか。（コピー元で）
・見出し行を貼り付け対象から除きたいなら、Ｒｅｓｉｚｅを使う。
・他ブックへの処理は、
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_070_11.html
シートやブックを越えたRangeオブジェクト取得
などを参考に。
Ｇｏｏｇｌｅで「Ｅｘｃｅｌ　ＶＢＡ　他ブック参照」などで照会。
・Ａブックに累積したいなら、張り付けるとき、そのつど、最終行の次行
lr=（Aブック・シート名).Range("A100000").End(xlUp).Row +1
のようなのが使えないか。
・Ｂブックの数だけ繰り返す。
など浮かんだが。

お礼

ありがとうございます。
質問分かりにくかったでしょうか。すみませんでした。
教えて頂いた内容も検討してみたいと思います。