複数のExcelブックから一覧表を作成する方法を教えてください Excelで関数かマクロを使い複数の

複数のExcelブックから一覧表を作成する方法を教えてください

Excelで関数かマクロを使い複数のExcelブックを集計し一覧表を作成する方法を教えてください。

新規フォルダの中にExcelブックが300個あり、各ブックにはsheet１～sheet3までがあります。
300個のExcelブックのsheet1のA1の文字とB1の文字とC1の文字を全て一覧表シートのA1～C1 300行まで一気に転記する方法を教えてください。

質問者からの補足コメント

• tom04様、何度かチャレンジしてみましたがうまくいきませんでした。セルが結合してあると出来ないのでしょうか。

    補足日時：2018/03/01 12:39

• アドバイスありがとうございます。
  複数Excelブックのsheet１にC8～I9まで結合されているのを集計シートのA1に。K17～T19まで結合されているのを集計シートのB1に。K22～T24まで結合されているのを集計シートのC1に。といったように集計したいです。よろしくお願いします。

    補足日時：2018/03/01 15:57

• エラーになってばかりです。
  実行エラー52 ファイル名または番号が不正ですと出てきます。
  保存先のパスの間違いなのでしょうか？

    補足日時：2018/03/01 21:35

• その通りにしてみましたら、○○（個人名の為○○にしてます）xlsが見つかりません。ファイル名およびファイルの保存場所が正しいかどうかを確認してください。最近使用したファイルの一覧からファイルを開こうとしている場合は、そのファイル名が変更されていないこと、移動または削除されていないことを確認してください。と表示され、意味が分からず先に進めません。どうかよろしくお願い致します！

    補足日時：2018/03/01 22:21

No.5 ベストアンサー 回答者： tom04 回答日時： 2018/03/03 00:55

続けてお邪魔します。

もう一度最初からやり替えてみました。
↓のコードではどうでしょうか？

Sub Sample2()
Dim cnt As Long, wB As Workbook, wS As Worksheet
Dim myPath As String, fN As String
myPath = "保存場所のパス" & "\"
fN = Dir(myPath & "*.xlsx")
Application.ScreenUpdating = False
Do While fN <> ""
Workbooks.Open (myPath & fN)
cnt = cnt + 1
Set wB = ActiveWorkbook
Set wS = wB.Worksheets(1)
With ThisWorkbook.Worksheets("Sheet1").Cells(cnt, "A")
.Value = wS.Range("C8")
.Offset(, 1) = wS.Range("K17")
.Offset(, 2) = wS.Range("K22")
End With
Application.DisplayAlerts = False
wB.Close
Application.DisplayAlerts = True
fN = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

※　ひとつひとつファイルを開いて処理しています。
ファイルが300位あるというコトなので、それなりに時間を要すると思います。m(_ _)m

この回答へのお礼

tom04様、最後にアドバイスいただいたコードでうまく行きました。時間は少し要しましたが簡単に300名の集計ができるので助かりました。ありがとうございました。

お礼日時：2018/03/04 19:43

No.4 回答者： tom04 回答日時： 2018/03/01 21:53

＞エラーになってばかりです。

＞実行エラー52 ファイル名または番号が不正ですと出てきます。

おそらく、ファイルが開いていないのではないかと思います。
「保存場所のパス」を今一度確認してみてください。

①　保存場所のフォルダを一度クリックし、フォルダ内のファイルを表示させる（フォルダを開く）
②　表示されたExcelファイル（どのファイルでも構いません）のアイコン上で右クリック
③　プロパティを選択

表示された画面上の「場所」の部分が「パス」になります。
（おそらく「C:\Users\○○\Documents\・・・」のような感じになっているはずです）

画面上でその部分を左から右へずぃ～～～！っとドラッグ　→　右クリック　→　コピー
前回のコードの「保存場所のパス」の部分に貼り付けてみてください。

※　前後のダブルクォーテーション「"」は必要です。
※　当然のコトですが、検索したいファイルは同一フォルダ内にある！という前提です。m(_ _)m

No.3 回答者： tom04 回答日時： 2018/03/01 16:33

すべてのファイルのSheet1が同じように結合されているのですね？

前回の5行を

With ThisWorkbook.Worksheets("Sheet1").Cells(cnt, "A")
.Value = wS.Range("C8")
.Offset(, 1) = wS.Range("K17")
.Offset(, 2) = wS.Range("K22")
End With

にしてみてください。m(_ _)m

No.2 回答者： tom04 回答日時： 2018/03/01 15:48

No.1です。

＞セルが結合してあると出来ないのでしょうか。

どのようにセル結合してあるかによって当然コードも変わってきます。
前回のコードの

With ThisWorkbook.Worksheets("Sheet1").Cells(cnt, "A")
.Value = wS.Range("A1")
.Offset(, 1) = wS.Range("B1")
.Offset(, 2) = wS.Range("C1")
End With

の部分に手を加える必要があるのではないでしょうか？m(_ _)m

No.1 回答者： tom04 回答日時： 2018/02/26 23:39

こんばんは！

一例です。
標準モジュールにしてください。

Sub Sample1()
Dim cnt As Long, wS As Worksheet, wB As Workbook
Dim myPath As String, fN As String
myPath = "保存場所のパス" & "\"
fN = Dir(myPath & "*.xlsx")
Application.ScreenUpdating = False
Do Until fN = ""
Workbooks.Open fN
Set wB = ActiveWorkbook
Set wS = wB.Worksheets(1)
cnt = cnt + 1
With ThisWorkbook.Worksheets("Sheet1").Cells(cnt, "A")
.Value = wS.Range("A1")
.Offset(, 1) = wS.Range("B1")
.Offset(, 2) = wS.Range("C1")
End With
wB.Close
fN = Dir()
Loop
Application.ScreenUpdating = True
MsgBox "完了"
End Sub

※　コード内の「保存場所のパス」は実情に合わせてください。
※　ファイルの拡張子は「xlsx」としています。m(_ _)m