Excel他のブックから情報をコピーする方法

質問

いつも大変参考にさせていただいております。

Excelで他のブックの値を、今使っているブックにコピーする方法を探しております。

値のみを引く方法として、WEBより以下の方法がわかりました。
Sub TEST1()
Workbooks.Open Filename:=ThisWorkbook.Path & "\Book2.xlsx"
Dim Wb1, Wb2
Set Wb1 = ThisWorkbook
Set Wb2 = Workbooks("Book2.xlsx")
Wb2.Worksheets("Sheet1").Range("D7:D9").Copy Wb1.Worksheets("Sheet1").Range("B1")
End Sub

これを変更して作っていきたいとおもうのですが、最終的にVBAを起動させると コピー元となるExcelをユーザーが自分で選択するようにしたいです。（Excelの画像の挿入で、デバイスから選択　とするようなイメージです）
その場合、どのようにしたら成せるでしょうか。
選択するブックは必ず複数シートあり、そのすべてをコピーしたいと思っています。

どなたか分かるかた、ご助力いただけますと助かります。

回答No.5

kkkkkm · ベストアンサー

> Wb2.Worksheets("Sheet1").Range("D7:D9").Copy Wb1.Worksheets("Sheet1").Range("B1")　で
> 各箇所を指定しようと思ったのですが、うまくいきませんでした。
> 「アプリケーション定義、オブジェクト定義のエラーです」と表示されてしまします。

その部分ではエラーにならないと思いますよ。
アプリケーション定義、オブジェクト定義のエラーです
で検索して該当する状態の部分が無いか探してみてください。

回答No.4

kkkkkm

> 各シートごとに記入されているセル範囲が異なります。

どのような異なり方なのかが分かりませんので参考になると思われるサイトだけ紹介しておきます。

最終行・最終列の取得方法
https://excel-ubara.com/excelvba4/EXCEL222.html

最終行・最終列取得の説明ですが
CurrentRegion
UsedRange
はそれだけで範囲を取得できます。ただし、それぞれ問題点がありますのでそのあたりは説明を読んでくださいね。

以下のような感じでそれぞれどこまで範囲として取得されるのかテストすれば一応確認はできますよ。

Sheets(1).UsedRange.Select

Sheets(1).Range("A1").CurrentRegion.Select

お礼

何度もご教授いただき誠にありがとうございます。

いただいたURLの方法ですと、既述のある最終列と最終行までを見に行く　というものだったのですが、コピーしたい範囲はシート内の限定的な範囲になります。
その為、 Wb2.Worksheets("Sheet1").Range("D7:D9").Copy Wb1.Worksheets("Sheet1").Range("B1")　で
各箇所を指定しようと思ったのですが、うまくいきませんでした。
「アプリケーション定義、オブジェクト定義のエラーです」と表示されてしまします。

この件ご助力いただけませんでしょうか。

回答No.3

kkkkkm

> いただいた回答ですと結果がエラーとなりました。「パスがみつかりません」と表示されます。

ChDir "C:\Ok"

のところを変更していないからだと思いますよ。

> 第一シートは取得する情報がありません。
> また、取得する側（コピー内容を張り付ける側）のExcelにはその複数シートの内容を１シートにまとめたいと思っています。

回答No.1の感じかなと思いますので

取得される側の一番左端のシートはコピー対象にしないという事に変更して

Sub TEST3()
Dim Wb1 As Workbook, Wb2 As Workbook
Dim Ws As Worksheet
Dim mFileName As Variant
Dim LastRow As Long
Dim i As Long

ChDir "C:\Ok"
mFileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xls*")
If mFileName = False Then
Exit Sub
End If

Set Wb1 = ThisWorkbook
Set Wb2 = Workbooks.Open(mFileName)
With Wb1.Worksheets("Sheet1")
For i = 2 To Wb2.Sheets.Count
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
If .Cells(1, "B").Value = "" Then LastRow = 0
Wb2.Sheets(i).Range("D7:D9").Copy .Cells(LastRow + 1, "B")
Next
End With

Set Wb1 = Nothing
Set Wb2 = Nothing

End Sub

お礼

度々のご回答ありがとうございます。
すでにベストアンサーなのですが、追加して伺っても良いでしょうか。

取り込みたい複数シートはシート名固定で、各シートごとに記入されているセル範囲が異なります。
個別シートごとに　Range("")　で範囲指定して、データを取得しようと思っています。
今、いただいた内容を調べながら解釈しようとしていますが、上記の方法もご教授頂けますと助かります。

回答No.2

kkkkkm

> 選択するブックは必ず複数シートあり、そのすべてをコピーしたいと思っています。

"D7:D9"をシート毎にコピーするという事も考えられますね。このあたり説明不足だと思いますよ。
全てのシートのデータを全てコピーするのでしたらブックをコピーすればいいと思うので無しですよね。

回答No.1で忘れてましたが
開くフォルダを指定したい場合は、今回のようにフォルダを指定してください
ChDir "C:\Ok"　
みたいにです。

Sub TEST2()
Dim Wb1 As Workbook, Wb2 As Workbook
Dim Ws As Worksheet
Dim mFileName As Variant
Dim i As Long, SCnt As Long

ChDir "C:\Ok"
mFileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xls*")
If mFileName = False Then
Exit Sub
End If

Set Wb1 = ThisWorkbook
Set Wb2 = Workbooks.Open(mFileName)

SCnt = Wb1.Sheets.Count

If SCnt > Wb2.Sheets.Count Then
SCnt = Wb2.Sheets.Count
End If

For i = 1 To SCnt
Wb2.Sheets(i).Range("D7:D9").Copy Wb1.Sheets(i).Cells(1, "B")
Next

Set Wb1 = Nothing
Set Wb2 = Nothing

End Sub

お礼

ご回答いただきありがとうございます。

質問させていただいたのは例で、いただいた答えをもって私のやりたいことに落とし込もうと思っていました。

実際には取得される側のExcelにはシート名が固定された複数シートあり（シート数固定）、第一シートは取得する情報がありません。
また、取得する側（コピー内容を張り付ける側）のExcelにはその複数シートの内容を１シートにまとめたいと思っています。

その後に取得する側のExcelには各表があり、その１シートにまとめた内容を関数を使ってそれぞれの表に表示する。
というExcelをつくりたいと思っています。

いただいた回答ですと結果がエラーとなりました。「パスがみつかりません」と表示されます。
また何かわかりましたらご教授いただけますと助かります。

回答No.1

kkkkkm

> 選択するブックは必ず複数シートあり、そのすべてをコピーしたいと思っています。

複数シートのD7:D9全てをB列に追加コピーしていくと考えたら

Sub TEST1()
Dim Wb1 As Workbook, Wb2 As Workbook
Dim Ws As Worksheet
Dim mFileName As Variant
Dim LastRow As Long

mFileName = Application.GetOpenFilename(FileFilter:="Excelファイル,*.xls*")
If mFileName = False Then
Exit Sub
End If

Set Wb1 = ThisWorkbook
Set Wb2 = Workbooks.Open(mFileName)
With Wb1.Worksheets("Sheet1")
For Each Ws In Wb2.Worksheets
LastRow = .Cells(.Rows.Count, "B").End(xlUp).Row
If .Cells(1, "B").Value = "" Then LastRow = 0
Ws.Range("D7:D9").Copy .Cells(LastRow + 1, "B")
Next
End With

Set Wb1 = Nothing
Set Wb2 = Nothing

End Sub