VBA 他のブックから複数のシートのデータをコピー

質問

VBA初心者です。
他のブックの複数のシートの最終行のデータをコピーし1つのシートにまとめたいと思っています。
参照元
シート1　最終行20　AからD
シート2　最終行30　AからD
シート3　最終行15　AからD　のそれぞれのデータ
メインシート
1行目　シート1のAからD
2行目　シート2のAからD
3行目　シート3のAからD　を値のみ貼り付けたいです

色々と検索しチャレンジするシート1のみであればなんとか成功するまで完成したのですが、インデックスが有効ではありませんとでてエラーがでます。原因は、シート2のデータをコピーする際、参照元のファイルがActiveになっていないからだと考えているのですが、参照元のファイル名が毎回違いますので、ファイルを選択してファイルを開いてから作成しようとチャレンジしています。

Sub Copy()
'コピー元のファイルを選択して開く
Dim OpenFile As String
ChDir "C:\Users\name\Documents\folder"
OpenFile = Application.GetOpenFilename("Excelブック,*.xlsx")
MsgBox OpenFile & " を開きます"
Workbooks.Open FileName:=OpenFile

'データをコピー
'シート1
Worksheets("シート1").Range("A20:D20").Copy
Workbooks("メインブック.xlsm").Worksheets("メインシート").Activate
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'シート2
Worksheets("シート2").Range("A30:D30").Copy
Workbooks("メインブック.xlsm").Worksheets("メインシート").Activate
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

End Sub

良きアドバイスよろしくお願いします。

回答No.1

kkkkkm · ベストアンサー

以下のどちらかで試してみてください。

コピー元やコピー先の質問のセル位置で決まっているのでしたら
一部Rangeの前に「.」があります。

Sub Test()
Dim wb As Workbook
Dim OpenFile As String

ChDir "C:\Users\name\Documents\folder"
OpenFile = Application.GetOpenFilename("Excelブック,*.xlsx")
MsgBox OpenFile & " を開きます"

Set wb = Workbooks.Open(OpenFile)

With Workbooks("メインブック.xlsm").Worksheets("メインシート")
.Range("A1:D1").Value = wb.Worksheets("シート1").Range("A20:D20").Value
.Range("A2:D2").Value = wb.Worksheets("シート2").Range("A30:D30").Value
.Range("A3:D3").Value = wb.Worksheets("シート3").Range("A15:D15").Value
End With

Set wb = Nothing

End Sub

コピー元やコピー先のセルはその時の最終行なので不定ということでしたら
一部CellsやRangeの前に「.」があります。

Sub Test2()
Dim wb As Workbook
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim OpenFile As String
Dim LastRowM As Long, LastRow1 As Long, LastRow2 As Long, LastRow3 As Long

ChDir "C:\Users\name\Documents\folder"
OpenFile = Application.GetOpenFilename("Excelブック,*.xlsx")
MsgBox OpenFile & " を開きます"

Set wb = Workbooks.Open(OpenFile)
Set ws1 = wb.Worksheets("シート1")
Set ws2 = wb.Worksheets("シート2")
Set ws3 = wb.Worksheets("シート3")

With Workbooks("メインブック.xlsm").Worksheets("メインシート")
If .Range("A1") = "" Then
LastRowM = 0
Else
LastRowM = .Cells(Rows.Count, "A").End(xlUp).Row
End If
LastRow1 = ws1.Cells(Rows.Count, "A").End(xlUp).Row
.Cells(LastRowM + 1, "A").Resize(1, 4).Value = ws1.Cells(LastRow1, "A").Resize(1, 4).Value
LastRow2 = ws2.Cells(Rows.Count, "A").End(xlUp).Row
.Cells(LastRowM + 2, "A").Resize(1, 4).Value = ws2.Cells(LastRow2, "A").Resize(1, 4).Value
LastRow3 = ws3.Cells(Rows.Count, "A").End(xlUp).Row
.Cells(LastRowM + 3, "A").Resize(1, 4).Value = ws3.Cells(LastRow3, "A").Resize(1, 4).Value
End With

Set wb = Nothing
Set ws1 = Nothing
Set ws2 = Nothing
Set ws3 = Nothing

End Sub

お礼

丁寧な説明ありがとうございます。
コピー元は変動しますが、コピー先は固定なので教えていただいたのを組み合わせて、希望通りの動作が行えました。
まだまだ分からないことが沢山ありますが、しっかりべんきょうしたいと思います。

回答No.4

imogasi

「コピー」と「値（だけの）代入」の用語の使い方に注意すること。
本件は、「値（だけの）代入」で良いようだ。
処理速度の方からして、出来るなら、「値（だけの）代入」がおすすめ。
ーー
本件は、質問するほどのことでもないと思う。
回答が出るVBAコードの丸写しを期待するな。
本件のパターンを理解すことが、今後のVBA上達のカギになるだろう。
'--

（A)値を持ってくる先のシート（TO)
値を持ってくる（To）シートは、処理中は、１つで変わらないだろう。
それを　set ws1=worksheets(”シート名")で定義する。
ーー
（Ｂ）値を持ってくる元のシート（From)
これが「複数あるらしいから、下記でシートの名前定義。３シートの例として、
wsn = Array("aa", "bb", "cc")
"aa", "bb", "cc"の相互の順番は、都合のよいように並べておく。
１０シート程度以下と予想する。何十もあれば、質問に書いておくべきだ。
他のやり方を考えるべきだから。
（シートのインデックスで定義する方法もあるが。）
（C）ただし持ってくるデータが、複数ブックなのかどうか質問に明記してないのでは。
複数ブックからなら、ブック名の部分を、シート名指定の前の先頭につけて限定しないといけない。
https://plus-info-tech.com/vba-sheet-copy
の例で言えば
インポート先のエクセルファイル名の文字列を取得
importPath = "C:\Users\example\インポート先のExcel.xlsx"
'データをインポート(シートの内容をコピー)　OPENしておく
Set importWb = Workbooks.Open(importPath)
これでブック名が確定。
importWb.worksheets("シート名").cells(・・)
処理が終わったところで、CLOSEしておく。
ーー
データを持ってくるブックは１つとしての例
Sub test01()
wsn = Array("aa", "bb", "cc")
For Each ws In wsn
MsgBox Worksheets(ws).Cells(1, "a")
Next
End Sub
これで各シートのA1セル（例）の値が捉えられる。
ーー
本件の「VBAコード作成の手数」の最大の問題は、
ｗｓ１＜ーーー上記のWsシート
のセルの対応関係の記述にある。一応、１セルずつ記述するつもりで考えること。
　何か言葉で表されるような、rule表現があれば、質問に特記しておくべきなんだ。
セルのカタマリなど。
例
Sub test02()
Worksheets("bb").Range("A1:A3").Copy Worksheets("aa").Range("A1")
End Sub
そうすれば、VBAコード行が少なくて済むときもあろう。

お礼

色々とアドバイスを頂きありがとうございます。
一つ一つ考えてしっかり作成出来るように頑張りたいと思います。

回答No.3

kkkkkm

No.1の補足です。

元のコードの最小限の変更でしたら

コピー貼り付けの部分で.ActivateやSelectをやめて直接指定すればエラーにはならないと思いますが、値貼り付けですのでコピー貼り付けせずにNo.1のように値を直接代入したほうがいいのではと思います。

'データをコピー
'シート1
Worksheets("シート1").Range("A20:D20").Copy
Workbooks("メインブック.xlsm").Worksheets("メインシート").Range("A1").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False
'シート2
Worksheets("シート2").Range("A30:D30").Copy
Workbooks("メインブック.xlsm").Worksheets("メインシート").Range("A2").PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=False

回答No.2

kkkkkm

No.1追加です。
転記部分をループにすると短くできますし、シートが増えても変更が楽かもしれません。
Test2()の場合だと以下で(Test1()も同じような感じにすればできます)

Sub Test3()
Dim wb As Workbook
Dim ws(3) As Worksheet
Dim OpenFile As String
Dim LastRowM As Long, LastRow As Long
Dim i As Long

ChDir "C:\Users\name\Documents\folder"
OpenFile = Application.GetOpenFilename("Excelブック,*.xlsx")
MsgBox OpenFile & " を開きます"

Set wb = Workbooks.Open(OpenFile)
Set ws(1) = wb.Worksheets("シート1")
Set ws(2) = wb.Worksheets("シート2")
Set ws(3) = wb.Worksheets("シート3")

With Workbooks("メインブック.xlsm").Worksheets("メインシート")
If .Range("A1") = "" Then
LastRowM = 0
Else
LastRowM = .Cells(Rows.Count, "A").End(xlUp).Row
End If
For i = 1 To UBound(ws)
LastRow = ws(i).Cells(Rows.Count, "A").End(xlUp).Row
.Cells(LastRowM + i, "A").Resize(1, 4).Value = ws(i).Cells(LastRow, "A").Resize(1, 4).Value
Next
End With

Set wb = Nothing
Set ws(1) = Nothing
Set ws(2) = Nothing
Set ws(3) = Nothing
End Sub