フォルダ内の複数ファイルから、特定セルだけを抽出し、並び替えて集約したい

フォルダ内の複数ファイルから、特定セルだけを抽出し、並び替えて集約したい

VBA初心者です。
VBAが書かれたブックと同一フォルダ内にある200個のブックから、特定セルの値を取得し、1つのブックに集約したいです。全てのブックを1つ1つ開いて手作業でコピペするのが大変な為、何かVBAで良い方法はありませんでしょうか？　この作業は毎月発生します。まだ凄く簡単なマクロしかわからない為、具体的なコードを書いて頂けると嬉しいです。


1つのファイルに社員3人分のデータが入っています。
集約の際は、これを縦方向に集約したいです。
言葉で上手く説明できないため、画像を添付します。

画像上半分は集約元のブックの内容です。200個全て同じように入力されています。
画像下半分は集約後のブックイメージです。

◆集約元ブック
　nameという名前のシートしかありません。
　
　＜取得したいセル＞
　C列　C4～C5と、C9～C11
　D列　D4～D5と、D9～D11
　E列　E4～E5と、E9～E11
　

◆集約先ブック
　集約シートという名前のシートしかありません。
　A2セルから書き始めたいです。


◆PC環境
　Windows10Pro 64bit
　office2013

No.2 ベストアンサー 回答者： Qchan1962 回答日時： 2021/05/15 00:32

こんばんは

既に回答がありますが、一例として配列での処理方法です

Sub Sample()
Dim folderPath As String, fname As String
Dim n As Long, i As Long
Dim Ary()
folderPath = ThisWorkbook.Path & "\"
fname = Dir(folderPath & "\" & "*.xlsx")
Do Until fname = ""
Application.ScreenUpdating = False
With Workbooks.Open(folderPath & fname)
For i = 3 To 5
ReDim Preserve Ary(4, n)
Ary(0, n) = Cells(4, i)
Ary(1, n) = Cells(5, i)
Ary(2, n) = Cells(9, i)
Ary(3, n) = Cells(10, i)
Ary(4, n) = Cells(11, i)
n = n + 1
Next
.Close SaveChanges:=False
End With
fname = Dir
Loop
With ThisWorkbook.Worksheets(1)
.Range("A2").Resize(UBound(Ary, 2) + 1, 5) = _
Application.Transpose(Ary)
End With
Application.ScreenUpdating = True
End Sub

この回答へのお礼

ありがとうございます。
配列ですね。配列は、なんだかとっても難しそうなイメージでしたが、ご教示頂いたコードは応用で他のものにも使えそうなので、こちらをベストアンサーとさせて頂ければと思います。

教えて頂いたコードで試したら、バッチリ集約出来、これで毎月の作業にかかる時間が短縮できミスもなく作業が進み楽になるので、大変助かりました。

お礼日時：2021/05/15 20:48

No.1 回答者： fujillin 回答日時： 2021/05/14 22:30

こんばんは

なんだか、ほとんど同じ内容の質問に今日回答したような記憶が・・・

不明点はテキトーです。
あとは、ご随意に。

Sub Sample_Q12359472()
Dim fName As String, rng

Const folderPath = "C:\hogehoge\test" ' 指定フォルダパス

Application.ScreenUpdating = False
Set rng = Worksheets(1).Range("A2:H4")
rng.Worksheet.Rows("2:" & Rows.Count).ClearContents

fName = Dir(folderPath & "\*.xlsx")
While fName <> ""
　With Workbooks.Open(folderPath & "\" & fName)
　　.Worksheets(1).Range("C4:E11").Copy
　　rng.PasteSpecial Paste:=xlPasteValues, Transpose:=True
　　Set rng = rng.Offset(3)
　　.Close False
　End With
fName = Dir()
Wend

rng.Worksheet.Range("C2:E2").Resize(rng.Cells(1, 1).Row).Delete (xlShiftToLeft)
Application.ScreenUpdating = True
End Sub

この回答へのお礼

ありがとうございます。
fujillinさんの他の方への回答を見たら、確かに似たような質問に回答なさってましたね。大変失礼しました。コードをご教示いただき、大変助かりました。

全ての範囲を集約したいブックに貼り付けて、最後に不要列を削除するという発想は、自分には思いつきませんでした。勉強になりました。

お礼日時：2021/05/15 20:45