横にコピーするには・・。

質問

教えてください・・。

01.xls・02.xls・03.xlsとあり、その中のシート（01・02・03）をコピーして、全部というシートにまとめたいと思っています。
列にデータを追加したいのですが、行にデータが追加されてしまいます・・。
どうしたらいいのか教えてください。

01のシートがＡからＤまで
02のシートがＥからＧまで
03のシートがＨからＬまで
とコピーをしたいと思っています・・。

---------

PathName = ThisWorkbook.Path & "\"
ArrBook = Array("01.xls", "02.xls", "03.xls")
For i = LBound(ArrBook) To UBound(ArrBook)
Workbooks.Open PathName & ArrBook(i)
Next

Set WS(1) = Workbooks("01.xls").Worksheets("01")
Set WS(2) = Workbooks("02.xls").Worksheets("02")
Set WS(3) = Workbooks("03.xls").Worksheets("03")
Set WS(4) = ThisWorkbook.Worksheets("全部")
With WS(4)
.Cells.ClearContents
.Cells(1, 1) = "Ａ"
.Cells(1, 2) = "B"
.Cells(1, 3) = "C"
.Cells(1, 4) = "D"
.Cells(1, 5) = "E"
.Cells(1, 6) = "F"
.Cells(1, 7) = "G"
.Cells(1, 8) = "H"
.Cells(1, 9) = "I"
.Cells(1, 10) = "J"
.Cells(1, 11) = "K"
.Cells(1, 12) = "L"
.Cells(1, 13) = "M"
.Cells(1, 14) = "N"
.Cells(1, 15) = "O"
.Cells(1, 16) = "P"
.Cells(1, 17) = "Q"
LastRow(1) = WS(1).Range("A65536").End(xlUp).Row
LastRow(2) = WS(2).Range("A65536").End(xlUp).Row
LastRow(3) = WS(3).Range("A65536").End(xlUp).Row

For i = 1 To 3
LastRow(4) = .Range("A65536").End(xlUp).Row + 1
WS(i).Rows("2:" & LastRow(i)).Copy .Cells(LastRow(4), 1)
LastRow(4) = .Range("A65536").End(xlUp).Row

End With

For i = LBound(ArrBook) To UBound(ArrBook)
Workbooks(ArrBook(i)).Close SaveChanges:=False
Next

End Sub

回答No.1

keithin · ベストアンサー

横にコピーするには，単に横に貼ってくだけです。

PathName = ThisWorkbook.Path & "\"
ArrBook = Array("01.xls", "02.xls", "03.xls")
For i = LBound(ArrBook) To UBound(ArrBook)
Workbooks.Open PathName & ArrBook(i)
Next

Set WS(1) = Workbooks("01.xls").Worksheets("01")
Set WS(2) = Workbooks("02.xls").Worksheets("02")
Set WS(3) = Workbooks("03.xls").Worksheets("03")
Set WS(4) = ThisWorkbook.Worksheets("全部")
With WS(4)
.Cells.ClearContents

with .range("A1:Q1")
.formula = ="=MID(CELL("ADDRESS",A1),2,1)"　’←Ｑ列とか使ってないし
.value = .value
end with

' 01のシートがＡからＤまで
' 02のシートがＥからＧまで　←まちがい？
' 03のシートがＨからＬまで　←まちがい？　

with ws(1)
.range(.range("A2"), .range("D65536").end(xlup)).copy ws(4).range("A2")
end with

with ws(2)
.range(.range("A2"), .range("C65536").end(xlup)).copy ws(4).range("E2")
end with

with ws(3)
.range(.range("A2"), .range("E65536").end(xlup)).copy ws(4).range("H2")
end with

For i = LBound(ArrBook) To UBound(ArrBook)
Workbooks(ArrBook(i)).Close SaveChanges:=False
Next

end sub

お礼

素早くご返答頂きありがとうございます。
無事に解決できました。

感謝しております。