複数CSVファイルをExcel形式１つにまとめたい

質問

ＶＢＡ初心者です。

似たような質問・回答がありますが、どうも私の意図するところと異なるので、
新たに質問させていただきます。

どうぞお願いします。

仕事場で、基本１日１ファイル取得している複数のCSVファイルを、
1週間に一度Excelファイルに一週間分のデータを追加し、
最終的には１か月毎に１つのExceファイル（１シート）に集計してます。

全ファイルとも内容は同じで、１シートで作成されており、
タイトル行は１行目、２行目以降データ（行：データ数はファイル毎に異なる）、
列数はA-IV列といった構成になります。

新しい１つのファイルにまとめる際には、
B列とG列のみ抽出し、一行目にタイトル行、２行目からデータ、
最終行に次のファイルのデータと、いうように複数のファイルのデータをつなげて
１つのファイルにしたいのです。

ちなみに出来上がったExcelファイルとしては、
A列に元CSVファイルのB列データ、C列に元CSVファイルのG列データ、
B列に各データがどのCSVファイルの物か分かるように、
各ファイル名の日付にあたる後ろ部分を表示させたいのです。

ファイル名から日付を拾えない場合は、
ファイルをまとめる前に、列を挿入し、
C列にデータ日付の項目を作り、そこに日付を入力し、
まとめる際に、B・C列＋G列を抽出、といった形で、まとめられたらと思ってます。

＊各Exceファイルのタイトルの後部分がデータの日付を表す
（タイトル例：0803abcde2013_08_03.xls)
B列２行目以降に、それぞれ抽出したデータのファイル名から、
日付にあたる部分を書き出し(8月3日と言ったように)表示させたい。
場合によっては、前部分を抽出するパターンもあるので、そちらもお願いします。

＊今後、他の何種類かの複数CSVファイルでもファイル毎に
（こちらも全ファイルとも内容は同じ)同様に１カ月毎にまとめたいので、
違う条件でも抽出できるように、応用できたらと、考えております。
（抽出する列がB列とI列のみ、A～C列＋F列など)

VBAで作業したいと考えてます。色々とお手数ですが、よろしくお願いします。

また、他にお勧めのサイトや、参考になる質問がありましたら、
合わせて、教えていただけると幸いです。

回答No.4

mitarashi · ベストアンサー

あまり時間が空くとチェックしなくなってしまいます。数日間しかフォローしていませんが、皆さん同様だと存じます。
たまたま気付いたので、遅くなりましたが、一応お返事しておきます。

ご提示の情報だけでは、接続がうまくいっていないとしか言えません。
参照先にある様な基本的なコードで動作するかどうか、ご確認下さい。
こちらは「参照設定」するコードになっておりますので、参照設定をお忘れ無く。
http://home.att.ne.jp/zeta/gen/excel/c04p47.htm

参照設定については必要ならこちらをご覧下さい。
http://www.asahi-net.or.jp/~ef2o-inue/vba_k/sub04_040_04.html
http://www.happy2-island.com/access/gogo03/capter00307.shtml

環境によっては、下記のx違いがいくつも表示されますが、一番数字の大きなものにしておけば良いでしょう。
また、6.xというのもありますが、バグ対策バージョンで、機能は同様との事です。
Microsoft ActiveX Data Objects 2.x Library

お礼

返事が遅くなり申し訳ありません。
色々解説いただき、ありがとうございます。

回答No.3

mitarashi

#2です。
汎用化しようとして、Schema.iniにはまってました。
分かった事
・SQLで設定した事項は無効になり、Schema.iniの設定が有効となる。
・先頭から指定列までの列指定取込は出来るが、中抜きはできない。
・フィールド名を指定しても意味はなく、Col?の設定だけで取り込む。フィールド名に代えて適当にA,B,CとかでもOK
Access2000の頃は、Schma.ini.を使っていたと思うので、引っ張り出して試してみようかとも思いましたが、時間切れです。
という訳で、Schema.ini.は取り下げた、簡略化版を投稿しておきます。
importの綴りも違っておりました(^^;)

Const adOpenFowardOnly As Long = 0

Sub test()
Dim myRange As Range

Set myRange = Sheets(2).Range("a1")
Call importCSV("C:\Users\hoge\Desktop\testdata20130804.csv", Array(1, 2, 3, 7), myRange)
End Sub

'引数　CSVファイルのフルパス,取り込む列を示す配列、貼り付け先左上隅セル
'見出し行もデータの一部として取り込む
Private Sub importCSV(csvFileFullPath As String, importColumnArray As Variant, destRange As Range)
Dim cn As Object
Dim rs As Object
Dim mySQL As String
Dim strFields As String
Dim csvfilepath As String, csvfilename As String

csvfilepath = Left(csvFileFullPath, InStrRev(csvFileFullPath, "\"))
csvfilename = Right(csvFileFullPath, Len(csvFileFullPath) - Len(csvfilepath))
strFields = "F" & Join(importColumnArray, ",F")

Set cn = CreateObject("ADODB.Connection")
With cn
.Provider = "Microsoft.ace.OLEDB.12.0" 'Office2007以降
' .Provider = "Microsoft.Jet.OLEDB.4.0"
.ConnectionString = "Data Source=" & csvfilepath & ";" & _
"Extended Properties='Text; HDR=NO; FMT=Delimited'"
.Open
End With
Set rs = CreateObject("ADODB.Recordset")
mySQL = "SELECT " & strFields & " FROM " & csvfilename & ";"
rs.Open mySQL, cn, adOpenFowardOnly
destRange.CopyFromRecordset rs

Set rs = Nothing
cn.Close: Set cn = Nothing
End Sub

補足

お返事遅くなりすみません。

色々変更してみたのですが、
.Open
の、ところで、エラーが出てしまいます。
お手数ですが、更にアドバイス頂けると、幸いです。

宜しくお願いします。

回答No.2

mitarashi

最近ADOの復習をしていますので作成してみました。単独ファイルからの抽出の部分しかありませんので、ご参考になりましたら、以降はご自分でお願いします。CSVファイルを、デスクトップにおいて実行する前提になっています。
Const adOpenFowardOnly As Long = 0

Sub test()
Dim cn As Object
Dim rs As Object
Dim mySQL As String
Dim inportColumnArray As Variant
Dim strFields As String
Dim csvfilepath As String, csvfilename As String

csvfilepath = GetDesktopPath
csvfilename = "testdata20130804.csv"
'抽出する列番号を指定
inportColumnArray = Array(1, 2, 3, 4, 5, 7)
strFields = "F" & Join(inportColumnArray, ",F")

Set cn = CreateObject("ADODB.Connection")
With cn
'Office2007以降
.Provider = "Microsoft.ace.OLEDB.12.0"
'Office2003以前 2007以降でも動きますが
' .Provider = "Microsoft.Jet.OLEDB.4.0"

'敢えてHdr=Noにして先頭行は捨てる。
'型の自動判別のMaxScanRows無効のバグはace.OLEDB.12.0でも直っていない様です
'仕方が無いのでSchema.iniにも手を出してみました

.ConnectionString = "Data Source=" & csvfilepath & ";" & _
"Extended Properties='Text; HDR=NO; FMT=Delimited'"
.Open
End With
Set rs = CreateObject("ADODB.Recordset")
mySQL = "SELECT " & strFields & " FROM " & csvfilename & ";"
'型変換エラーで悩まされる時は生かして下さい。すべて文字列で取り込みます。
'makeSchema csvfilepath, csvfilename, strFields

rs.Open mySQL, cn, adOpenFowardOnly
'とりあえずテンポラリシートに貼り付けて、ファイル名を付与する
'一行目以外を目的のシートの末尾に貼り付ける等して使用する
With Sheets("Sheet2")
.Cells.Clear
.Range("B1").CopyFromRecordset rs
.Range("B1").CurrentRegion.Offset(0, -1).Resize(, 1).Value = csvfilename
End With

Set rs = Nothing
cn.Close: Set cn = Nothing
End Sub

'取込型指定のSchama.iniを作る
Private Sub makeSchema(csvfilepath As String, csvfilename As String, strFields As String)
Dim FSO As Object
Dim i As Long
Dim buf As Variant

buf = Split(strFields, ",")
Set FSO = CreateObject("Scripting.FileSystemObject")
'OverWrite=true:default
With FSO.CreateTextFile(csvfilepath & "\" & "Schema.ini")
.writeline "[" & csvfilename & "]"
.writeline "ColNameHeader = False"
.writeline "Format = CSVDelimited"
For i = 0 To UBound(buf)
.writeline "Col" & CStr(i + 1) & "=" & buf(i) & " Char"
Next i
.Close
End With
Set FSO = Nothing
End Sub

'デスクトップのパス取得
Private Function GetDesktopPath() As String
Dim wScriptHost As Object, strInitDir As String
Set wScriptHost = CreateObject("Wscript.Shell")
GetDesktopPath = wScriptHost.SpecialFolders("Desktop")
Set wScriptHost = Nothing
End Function

回答No.1

n-jun

取りあえず考え方の１つとしてですが。

ADOを使ってCSVファイルを読み出す方法
http://www7b.biglobe.ne.jp/~whitetiger/ex/ex2002087.html

こう言った方法でＣＳＶファイルからデータを読み込む事は
出来ると思います。
⇒読み込む列を変える事での応用のし易さもありますけど、
逆に新規ブックで開いて無駄なところを削除し
残ったデータを貼り付ける方が早い場合もありそうですね。

あとはファイル名の部分が良くわからないですけど、
１週間分に該当するのかどうかの判定
（先週分を読み込まない方法）の必要性とかが、
ちょっとわかならかったもので。。。

＞場合によっては、前部分を抽出するパターンもあるので、そちらもお願いします。
ファイル名から日付を取得するって事なら、前から何文字とか後ろから何文字とか
あるいは正規表現などを用いるにしても、どのようなパターンがあるのかの
情報は必要かもしれませんね。

結局具体的な回答が出来ず申し訳ないです。