【VBA】フォルダ内の複数Excelのセルと列をコピー

お世話になります。
Excel2016にて作業をしておりますが、上手くいかないのでお知恵をお貸しいただきたく質問いたします。

【概要】
あるフォルダ内にある複数のExcelファイルから、特定のセル及び列を1つのExcelファイルに集約します。

【詳細】
1.あるフォルダ内に複数のExcelファイルがあります。
　いずれも「〜.xlsx」の形式で、ファイル数は日によって異なります。
2.これらのExcelファイルの、Sheet1のA1セルとA2セル、Sheet2のA列、C列を抽出して、1つのExcelファイルに貼り付けます。
3.列の長さはファイルによって異なります。
4.貼付→次の列へ移動、というサイクルをフォルダ内のExcelファイルの数だけ繰り返します。
5.集約したExcelファイルのイメージは以下の通りです。

　　　 A列 B列　C列 D列　E列……
1行目　A1　A2　 A1　A2
2行目　A列 C列　A列 C列
3行目　A列 C列　A列 C列
4行目　A列 C列　A列 C列
5行目　A列 C列　A列 C列
　　　 　↑　　　　↑
　　 （1.xlsx）（2.xlsx）

「列を集約」と「セルを集約」を同時に解決できずにおります。
ご助言をいただけますと大変ありがたいです。よろしくお願いいたします。

No.1 ベストアンサー 回答者： tom04 回答日時： 2019/04/05 16:29

こんにちは！

各ブックのSheet2のA・C列は1行目からでよいのでしょうかね？
尚、Sheet2のC列最終行とA列の最終行は同じ行数だとしています。

一例です。
コード記載ブックのSheet1に表示するとします。
標準モジュールにしてください。

Sub Sample1()
　Dim myPath As String, fN As String
　Dim wB As Workbook, wS1 As Worksheet, wS2 As Worksheet
　Dim cnt As Long, lastRow As Long, myCol As Long
　　myPath = "保存場所のパス" & "\"
　　fN = Dir(myPath & "*xlsx")
　　　Do Until fN = ""
　　　　Workbooks.Open myPath & fN
　　　　　Set wB = ActiveWorkbook
　　　　　Set wS1 = wB.Worksheets("Sheet1")
　　　　　Set wS2 = wB.Worksheets("Sheet2")
　　　　　　cnt = cnt + 1
　　　　　　myCol = cnt * 2 - 1
　　　　　　　With ThisWorkbook.Worksheets("Sheet1")
　　　　　　　　.Cells(1, myCol) = wS1.Range("A1")
　　　　　　　　.Cells(1, myCol + 1) = wS1.Range("A2")
　　　　　　　　lastRow = wS2.Cells(Rows.Count, "A").End(xlUp).Row
　　　　　　　　　Range(wS2.Cells(1, "A"), wS2.Cells(lastRow, "A")).Copy
　　　　　　　　　　.Cells(2, myCol).PasteSpecial Paste:=xlPasteValues
　　　　　　　　　Range(wS2.Cells(1, "C"), wS2.Cells(lastRow, "C")).Copy
　　　　　　　　　　.Cells(2, myCol + 1).PasteSpecial Paste:=xlPasteValues
　　　　　　　End With
　　　　　　wB.Close
　　　　　fN = Dir()
　　　Loop
　　MsgBox "完了"
End Sub

こんな感じではどうでしょうか？

※　コード内の「保存場所のパス」は実際のパスにしてください。m(_ _)m

この回答へのお礼

ありがとうございます！！
無事に解決できました。本当にありがとうございます。

お礼日時：2019/04/08 14:46