複数のcsvファイルを1つのEXCELファイルにマージするVBAを教えてください

csvファイル数は700～1000個程度でひとつのフォルダに格納されています。
このファイルをEXCEL形式で開くと、1行目にフィールド名(A～Z列で固定)、2行目以降にデータが入っています。行数はファイルにより１～100行程度で変動します。

このファイルを1つのエクセルファイルの同一シートに結合(マージ)するVBAがほしいです。
ここで、(できればですが)EXCELにマージするにあたり、1行目のみフィールドの値、2行目以降にそれぞれのcsvの2行目以降データの値を入れていくようにしたいです。つまり、フィールド名の行が何行も出てくるのを避けたいです。

申し訳ございませんが、ご指導いただけたら幸いです。よろしくお願いします。

No.1 回答者： fujillin 回答日時： 2009/04/16 21:03

自動化するならVBAを利用することになるでしょう。

基本的な考え方としては、csvをテキストファイルで1行ずつ読み込み、2行目以降をシートにコピーしてゆくということになるのかな？
（もちろん最初のファイルのみ、1行目も処理する）
処理が1行単位なので、カンマの処理さえできれば、あとはなんとかなるでしょう。

ただし、ファイル数1000、データの行数100とすると最大で100,000行くらいになるかも知れないので、1シートには納まらない可能性があります。
記入対象の行を監視して、シートの最大行を超えるなら、新しいシートに記入するなどの制御をしておいたほうがよさそうですね。

以下を組み合わせれば、概ねのところはできるかと。

1）フォルダ内の各ファイルを処理する方法は以下を参照
　http://homepage2.nifty.com/kasayan/vba/dir.htm
2）ファイルの読込み（テキストファイル）の基本はこちら
　http://officetanaka.net/excel/vba/file/file08.htm
3）csvの読み込みについてはこちら
　http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub0 …

各データ（セルに記入するデータ）内にカンマ（,）を含んでいる可能性がある場合は、その処理がちょいと面倒かも。

この回答へのお礼

fujillinさん

ありがとうございます！ご紹介いただいたもわかりやすいですね。これを一人で作れるかは不安ですが、参考にさせていただきます！

> 基本的な考え方としては、csvをテキストファイルで1行ずつ読み込み、2> 行目以降をシートにコピーしてゆくということになるのかな？
> （もちろん最初のファイルのみ、1行目も処理する）

おっしゃる通りです。

トータルのデータでEXCELの行数で何とか間に合いそうですが、やはり大きなデータになるので処理速度を考えると、ACCESSなどに一度インポートして、そのデータをEXCELで加工したほうが良さそうですかね。。

お礼日時：2009/04/16 21:49

No.2 ベストアンサー 回答者： end-u 回答日時： 2009/04/16 22:54

しばらく前に書いた事があるコードです。

参考になるようだったら応用してみてください。

'---------------------------------------------------------------------
Private Sub try()
　　Dim ws　As Worksheet
　　Dim fd　As String
　　Dim fn　As String
　　Dim ret As String
　　Dim i　 As Long
　　Dim n　 As Long
　　Dim x　 As Long
　　Dim s　 As Long
　　
　　fd = ThisWorkbook.Path & "\"
　　'fd = FDSELECT 'フォルダ選択の場合

　　If Len(fd) = 0& Then Exit Sub
　　Application.ScreenUpdating = False
　　'ActiveWorkbookにシートを追加して処理
　　Set ws = Sheets.Add
　　On Error GoTo errHndler
　　fn = Dir(fd & "*.csv")

　　x = 1
　　s = 1
　　Do Until Len(fn) = 0&
　　　　i = i + 1
　　　　'データCountにより次のセット先変更
　　　　n = n + x
　　　　'外部データ取り込み
　　　　x = CSVQRY(ws, fd & fn, ws.Cells(n, 2), s)
　　　　If x < 0 Then
　　　　　　Err.Raise Number:=1000, Description:="CSV読み込みに失敗"
　　　　ElseIf (n + x) >= Rows.Count Then
　　　　　　'行数overしてもエラーかからないため取り込み直し
　　　　　　ws.Rows(n).Resize(x).Delete
　　　　　　Set ws = Sheets.Add
　　　　　　n = 1
　　　　　　x = CSVQRY(ws, fd & fn, ws.Cells(n, 2), 1&)
　　　　End If
　　　　'ファイル名をA列にセット
　　　　ws.Cells(n, 1).Resize(x).Value = fn
　　　　s = 2
　　　　fn = Dir()
　　Loop

　　If i > 0 Then
　　　　ret = i & "files.done"
　　Else
　　　　ret = "no file"
　　End If

errHndler:
　　If Err.Number <> 0 Then
　　　　ret = Err.Number & vbTab & Err.Description
　　　　Debug.Print ret
　　End If
　　Application.ScreenUpdating = True
　　MsgBox ret
　　Set ws = Nothing
End Sub
'---------------------------------------------------------------------
Private Function CSVQRY(ByRef ws As Worksheet, _
　　　　　　　　　　　　ByRef fs As String, _
　　　　　　　　　　　　ByRef rs As Range, _
　　　　　　　　　　　　ByVal sr As Long) As Long
　　Dim cnt As Long

　　On Error GoTo errChk
　　With ws.QueryTables.Add(Connection:="TEXT;" & fs, _
　　　　　　　　　　　　　　Destination:=rs)
　　　　.AdjustColumnWidth = False
　　　　.TextFilePlatform = xlWindows
　　　　.TextFileStartRow = sr
　　　　.TextFileCommaDelimiter = True
　　　　.Refresh False
　　　　cnt = .ResultRange.Rows.Count
　　　　.Parent.Names(.Name).Delete
　　　　.Delete
　　End With
　　CSVQRY = cnt
　　Exit Function
errChk:
　　CSVQRY = -1
End Function
'---------------------------------------------------------------------
Private Function FDSELECT() As String 'フォルダ選択Function
　　Dim obj As Object
　　Dim ret As String

　　Set obj = CreateObject("Shell.Application") _
　　　　　　　.BrowseForFolder(0, "SelectFolder", 0)
　　If obj Is Nothing Then Exit Function
　　On Error Resume Next
　　ret = obj.self.Path & "\"
　　If Err.Number <> 0 Then
　　　　ret = obj.Items.Item.Path & "\"
　　　　Err.Clear
　　End If
　　On Error GoTo 0
　　Set obj = Nothing
　　FDSELECT = ret
End Function

この回答へのお礼

end-uさん
ありがとうございます！まさにこんなツールがほしいと思ってました!しかもA列にファイル名が追加されるのは、データの出所がわかるのでさらに便利ですね!早速活用させていただきます！
本当にありがとうございました。

これにて質問を締め切らせていただきます。

お礼日時：2009/04/17 11:16