VBAで複数エクセルシート内のセルを別シートに１つに統合

あるフォルダ配下に複数のエクセルがあります。
これを以下のように１つのシートに統合したいのです。

条件
　科目名（A科目 　　B科目　　C科目）のタイトル部分は不要
　フォルダ配下にあるすべてのエクセルファイルを統合したい。
　（ファイル数はいくつあるかは毎回異なるので、直接ファイルを指定する方法はできない。フォルダ指定したい。）


<１．ｘｌｓ>
　A科目 　　B科目　　C科目
390,200 　426,200　　801,600

<２．ｘｌｓ>
　A科目 　　B科目　　C科目
140,500 　333,200　　 1,400

↓
＜統合.csv＞
390,200 　426,200　　801,600
140,500 　333,200　　 1,400

以上よろしくお願いいたします。

No.1 回答者： merlionXX 回答日時： 2008/02/04 15:20

非常に大雑把な質問なのでこちらで勝手に以下の前提として回答します。

フォルダー内の集計される各ファイルのシート数は不定。
各シートのABC列２行目以降にデータが配置されている。
各シートのデータ行数は不定。但し、ABC各列の行数は同一とする。

このマクロを記述するエクセルは、同じフォルダー内にある別BOOKとする。
このマクロを記述するエクセルの集計するシート名はSheet1とし、ABC列に集計する。
集計後に作成される「集計.CSV」ファイルの格納先は自分でダイアログから指定する。


Sub Test()

Dim fn, wb, x, i, n, sh, myPath

myPath = ThisWorkbook.Path & "\"

fn = Dir(myPath & "*.xls") '選択したフォルダ内のExcelファイルを検索します

Do Until fn = "" '全て検索し終えると、fn = Empty となるので、その間以下を実行します

If fn <> ThisWorkbook.Name Then 'ファイルが自分以外なら

Set wb = Workbooks.Open(myPath & fn) '選択したファイルを開きます

For Each sh In wb.Worksheets '各シートごとに
x = sh.Cells(Rows.Count, 1).End(xlUp).Row '最終行取得
For i = 2 To x '2行目から最終行まで以下を実行します
n = n + 1
With ThisWorkbook.Sheets("Sheet1") '転記
.Cells(n, 1) = sh.Cells(i, "A")
.Cells(n, 2) = sh.Cells(i, "B")
.Cells(n, 3) = sh.Cells(i, "C")
End With
Next i
Next sh

wb.Close (False) '選択したファイルを閉じる

End If

fn = Dir() '次のファイルを検索
Set wb = Nothing

Loop '繰り返し

ThisWorkbook.Sheets("Sheet1").Copy
Application.Dialogs(xlDialogSaveAs).Show Arg1:="統合.csv", Arg2:=6

End Sub