「教えて!ピックアップ」リリース!

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

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

「フォルダ内の複数ファイルから、特定セルだ」の質問画像

A 回答 (2件)

こんばんは


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

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
    • good
    • 0
この回答へのお礼

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

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

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

こんばんは


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

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

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
    • good
    • 0
この回答へのお礼

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

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

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

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!

このQ&Aを見た人はこんなQ&Aも見ています


このQ&Aを見た人がよく見るQ&A

人気Q&Aランキング