excel 2010 VBAについて質問です

質問

複数(約２０００ファイル)のｃｓｖファイルのC列だけを抽出してまとめるVGAコード？
をしりたいのですがなにか方法はないでしょうか。
例
ファイル名が1.csv～100．ｃｓｖのファイル
1.csvのc1～c100をa1～a100
2.csvのc1～c100をb1～b100
100.csvのc1～c100をn1～n100 に抽出するようなことをしたいです。

1.csv 2.csv 抽出されたファイル.csv
ABCDEF ABCDEF ABCDEF
111 112 12
121 122 12
131 132 12
・・・ ・・・ 12
・・・　　　　 ・・・

ご回答よろしくお願いいたします。

回答No.2

keithin

白紙ブックをxlsm形式で保存しておく（xlsブックでは2000もデータを並べられないので注意する）
標準モジュールに下記を準備する

sub macro1()
　dim myPath as string
　dim myFile as string
　dim buf as string
　dim c as long, r as long

　mypath = "C:\test\"　’CSVファイルが保存してあるフォルダのパス

　myfile = dir(mypath & "*.csv")
　do until myfile = ""
　　open mypath & myfile for input as #1
　　c = c + 1
　　r = 0
　　do until eof(1)
　　　line input #1, buf
　　　r = r + 1
　　　cells(r, c) = split(buf, ",")(2)
　　loop
　　close #1
　　myfile = dir()
　loop
end sub

ＣＳＶファイルの保存してあるフォルダを正しく記入し、マクロを実行する。
通常は途中で画面の更新がおかしくなるので、マクロが終了するまで慌てずに待つ。

回答No.1

eden3616

Alt+F11でVBEを開き、挿入から標準モジュールを挿入してください。
最下のVBAコードを貼り付けて「設定」の項目より、フォルダパスを設定してください。
（フォルダパスの最後に「\」は付けないでください）
右上の「×」でVBEを閉じて、Alt+F8より「CSV集約」マクロを実行してください。

>複数(約２０００ファイル)

最大値の範囲が定かでないため、設定により変更できるようにしています。
ファイル数は2000として設定していますが、最大数が1998～2998など、
最大値が不明であれば3000や4000等最大値以上の値で設定してください。
また、Excel2010で取り扱える最大の列数は16384列ですので、番号はそれ以下でお願いします。
余分に番号を大きく撮りすぎると、その番号までファイルの有無を確認しますので処理時間がかかります。なるべく合わせるようにして下さい。

>1.csv、2.csv、100.csv

1～2000番までのうち、間に無い番号が有る場合、集約先の列は開けて集約するのか左につめて集約するのか設定できます。左に詰める場合は「0」を、列を飛ばす場合は「1」を以下の箇所に設定してください。（初期では1で無い列を詰めずに飛ばして集約しています）
Const sw As Integer = 1

■VBAコード
Sub CSV集約()
'設定-----------------------
'CSVファイルのあるフォルダパスを指定
Const dpath As String = "C:\フォルダパス"
'CSVファイルの最終番号を指定
Const mno As Long = 2000
'取得するセル範囲を指定
Const tre As String = "C1:C100"
'CSVファイルが無い場合に、集約先の列を左に詰めない場合は1、詰める場合は0
Const sw As Integer = 1
'---------------------------
Dim tbook As Workbook, i As Long, cnt As Long
Application.ScreenUpdating = False
With ThisWorkbook
　　For i = 1 To mno
　　　　If dir(dpath & "\" & i & ".csv") <> "" Then
　　　　　　cnt = cnt + 1
　　　　　　Set tbook = Workbooks.Open(Filename:=dpath & "\" & i & ".csv")
　　　　　　tbook.ActiveSheet.Range(tre).Copy .ActiveSheet.Cells(1, cnt)
　　　　　　tbook.Close
　　　　Else
　　　　　　If sw Then cnt = cnt + 1
　　　　End If
　　Next i
End With
Application.ScreenUpdating = True
MsgBox "終了しました"
End Sub