VBSでソート＆ファイル分割

質問

VBScriptでCSVファイルを最大5件のレコードになるように
ファイル分割しようとしています。
ただし、同じコードが複数のファイルに分かれないようにしたいです。

入力するCSVファイル(test_in.csv)は以下のような形式です。
(実際のファイルに項目行はありません)
連番,コード,フラグ,日付
01,0001,A,20091001
02,0002,A,20091001
03,0003,A,20091002
04,0001,U,20091003
05,0003,D,20091003
06,0004,A,20091003
07,0005,A,20091003
08,0001,D,20091005
09,0006,A,20091003
10,0006,A,20091003

※入力ファイルに同じコードのレコードが5件を超えることはありません)

上記の入力ファイルの場合は以下の3つのファイルに分割することになります。
【test_out_001.csv】
01,0001,A,20091001
04,0001,U,20091003
08,0001,D,20091005
02,0002,A,20091001

【test_out_002.csv】
03,0003,A,20091002
05,0003,D,20091003
06,0004,A,20091003
07,0005,A,20091003

【test_out_003.csv】
09,0006,A,20091003
10,0006,A,20091003

※コード"0003"のレコードは2件あるので、test_out_001.csvには出力せず、
　test_out_002.csvに出力します。
　コード"0006"についても同様でtest_out_003.csvに出力します。

処理の手順としては
入力ファイルのデータをコードでソートし、
1ファイルに5件を超えないように追加していくのかと思いますが、
ソートと5件制限はどのように記述すればよいでしょうか？

回答No.9

nda23 · ベストアンサー

5件ずつ、しかもコードが生き別れにならない出力の例です。
Sub WriteData()
Dim JIS, UTF, F, T, N, E, C, P
F = 0
N = 0
Do Until f > CNT
　　Set JIS = CreateObject("ADODB.Stream")
　　JIS.Open
　　JIS.Type = 2
　　JIS.Charset = "shift_jis"
　　N = N + 1
　　P = "C:\ok\CSV\T" & Right("00" & CStr(N), 3) & ".csv"
　　E = F + 4
　　If E < CNT Then
　　　　C = BLK(E).Code
　　　　If C = BLK(E + 1).Code Then
　　　　　　Do
　　　　　　　　E = E - 1
　　　　　　　　If C <> BLK(E).Code Then Exit Do
　　　　　　Loop
　　　　End If
　　End If
　　Do
　　　　JIS.WriteText BLK(f).Seq　& ","
　　　　JIS.WriteText BLK(f).Code & ","
　　　　JIS.WriteText BLK(f).Flag & ","
　　　　JIS.WriteText BLK(f).Date & vbNewLine
　　　　F = F + 1
　　　　if F > CNT Then Exit Do
　　Loop Until F > E
　　JIS.SetEOS
　　JIS.Position = 0
　　Set UTF = CreateObject("ADODB.Stream")
　　UTF.Open
　　UTF.Type = 2
　　UTF.Charset = "utf-16"
　　JIS.CopyTo UTF
　　JIS.Close
　　Set JIS = Nothing
　　UTF.SaveToFile P, 2
　　UTF.Close
　　Set UTF = Nothing
Loop
End Sub

お礼

分岐条件とループの脱出条件でここまで実現できるんですね…。
ご回答頂いたソースを実行してみて
実現したかった動作が確認できました。

後々、メンテナンスすることも考えられますので
一ステップごとに何の処理を行っているか理解しようと思います。

ご回答ありがとうございました。

回答No.8

nda23

並べ替えは以下のメソッドです。
Sub Sort(ByVal Fmi, ByVal Toi)
　　Dim F, T, D, M
　　F = Fmi
　　T = Toi
　　Set D = BLK(Fmi)
　　Do
　　　　Do While BLK(F).Comp(D) < 0
　　　　　　F = F + 1
　　　　Loop
　　　　Do While D.Comp(BLK(T)) < 0
　　　　　　T = T - 1
　　　　Loop
　　　　If F >= T Then Exit Do
　　　　Set M = BLK(T)
　　　　Set BLK(T) = BLK(F)
　　　　Set BLK(F) = M
　　　　F = F + 1
　　　　T = T - 1
　　Loop
　　F = F - 1
　　If F > Fmi Then Sort Fmi, F
　　T = T + 1
　　If T < Toi Then Sort T, Toi
End Sub

回答No.7

kztk

ヘッダーなしだと1行目が項目名と解釈されてしまうのですが・・・

と聞かれそうな気がしたので、こちらもご参照のこと。

http://www.ken3.org/cgi-bin/test/test090-1.asp

お礼

ORDER句を使う方法でソースを作成し、
期待通りのソート結果を得ることが出来ました。

この方法ですと基本的なSQLされ知っていれば
かなり応用することができますね。

ご回答ありがとうございました。

回答No.6

kztk

>"DBQ=D:\\vbs\\test0001.csv;" & _

「\\test0001.csv」が余計です。TextDriverではフォルダを指定し、個々のcsvファイルが1つのテーブルのように扱われます。

>さらにこの方法で後々SQLを発行するはずですが、
>CSVには項目名がないのでORDER句が作れないような気がするのですが…。

select * from test0001.csv order by 2

でいけると思います。
だめだとしてもschema.iniを作ればいけます。

ちなみに、ずぼらな私はソート処理を自前で考えるのがイヤなのと、Text Driverだとソートだけでなく集計や抽出条件をつけることもできて応用がきくのでこちらをお勧めしていますが、nda23さんのご提示されている方法が真っ当でエレガントな気もしますので、ご検討ください。

お礼

ご回答ありがとうございます。
回答遅れて申し訳ないです。

せっかくですので両方の方法とも試してみたいと思います。

回答No.5

nda23

SHIFT-JISに変換しますが、ファイルに保存する必要はありません。
読み込み処理は以下の通りです。

Sub ReadFile()
Dim JIS, UTF, ARY, TXT, TMP
Set JIS = CreateObject("ADODB.Stream") 'SHIFT-JIS側
JIS.Open
JIS.Type = 2 'テキスト形式という意味
JIS.Charset = "shift_jis"
Set UTF = CreateObject("ADODB.Stream") 'UTF-16側
UTF.Open
UTF.Type = 2
UTF.Charset = "utf-16"
UTF.LoadFromFile "C:\～\test_in.csv" '読み込み
UTF.Position = 0 '先頭に位置付ける
UTF.CopyTo JIS 'SHIFT-JISに変換（保存する必要は無い）
JIS.SetEOS
JIS.Position = 0 '先頭に位置付ける
UTF.Close 'UTF-16用オブジェクトにはもう用は無い
Set UTF = Nothing
Do Until JIS.EOS '読み込みループ
　　TXT = "" '1行分のデータを初期化
　　Do Until JIS.EOS '改行かEOSまでのループ
　　　　TMP = JIS.ReadText(1) '1文字ずつ読み込む
　　　　If TMP = vbLf Then Exit Do '改行なら抜ける
　　　　TXT = TXT & TMP
　　Loop
　　ARY = Split(Replace(TXT, vbCr, ""), ",") '復帰を削除し、カンマで区切る
　　Set TMP = New REC '新しいデータの入れ物をインスタンス化する
　　TMP.Seq　= ARY(0) '上記オブジェクトに記録(連番)
　　TMP.Code = ARY(1) '上記オブジェクトに記録(コード)
　　TMP.Flag = ARY(2) '上記オブジェクトに記録(フラグ)
　　TMP.Date = ARY(3) '上記オブジェクトに記録(日付)
　　CNT = CNT + 1 '配列要素数をインクリメント
　　ReDim Preserve BLK(CNT) '配列を拡張する
　　Set BLK(CNT) = TMP '配列の最後に追加する
LOOP
JIS.Close 'SHIFT-JIS用オブジェクトにはもう用は無い
Set JIS = Nothing
End Sub

お礼

ご回答ありがとうございます。
この方法だとファイルに保存する必要もなく
二次元配列のようなことができるんですね。

こちらの方法も試してみたいと思います。

回答No.4

kztk

>「■変換先のStreamを保存」
>まで試してみて変換先のファイルを開いてみたのですが、
>UTF-16BE形式になってしまいました。

ここ、

sto_in.SaveToFile "D:\vbs\test0001.csv",2

が、

sto_out.SaveToFile "D:\vbs\test0001.csv",2

です。せっかくSJISのストリームを作ったのに、元のUnicodeBEのストリームを保存しちゃだめです。

お礼

ご指摘ありがとうございます。その通りでした。
ADODB.Connectionを作成し、
以下の処理で変換先ファイルを開こうとしたのですが、
指定されたパスにファイルがないというエラーになってしまいました。
Dim objADOCon
Set objADOCon = CreateObject("ADODB.Connection")
objADOCon.Open "Driver={Microsoft Text Driver (*.txt; *.csv)};" & _
"DBQ=D:\\vbs\\test0001.csv;" & _
"ReadOnly=0"

さらにこの方法で後々SQLを発行するはずですが、
CSVには項目名がないのでORDER句が作れないような気がするのですが…。

回答No.3

nda23

この問題は３個の処理に分割すべきです。
(1)元データの読み込み
　UTF-16のデータを読み込んで、内部で処理できる形式に変換
(2)ソート
　各レコードをソート
(3)並べ替えデータの出力
　最大５件、かつ同一データが生き別れにならない出力

試しにプログラムしたら131ステップになってしまいましたので、
これをソックリ記載するのは難しいため、触りの部分を記載します。

'****　レコードの入れ物となるオブジェクト　****
Class REC
Dim Seq　'連番
Dim Code 'コード
Dim Flag 'フラグ
Dim Date '日付
Function Comp(Other) '比較関数(自身と引数）
If Code > Other.Code Then
　　Comp = 1 '自分の方が大きい
ElseIf Code< Other.Code Then
　　Comp = -1 '自分の方が小さい
Else 'コードが同じ場合は連番で決める
　　If Seq > Other.Seq Then '自分の方が大きい
　　　　Comp = 1
　　ElseIf Seq < Other.Seq Then
　　　　Comp = -1 '自分の方が小さい
　　Else
　　　　Comp = 0 'コード、連番とも等しい
　　End If
End If
End Function
End Class
'****** ここからメイン・メソッド ******
ReDim BLK(0) 'レコード（RECオブジェクト）の配列
Dim CNT 'レコード数（実際は配列の最大インデックス値）
CNT = -1 '配列の最大インデックス値なので、最初は-1

ReadData '（１）データの読み込み
If CNT > 0 Then Sort 0, CNT '（２）ソート
WriteData '（３）並べ替えたデータの書き込み
'****** ここまでメイン・メソッド ******

上記の例にはReadData、Sort、WriteDataのメソッドがありません。
メソッドの内容をご希望の場合は補足してください。

お礼

ご回答ありがとうございます。
>(1)元データの読み込み
>　UTF-16のデータを読み込んで、内部で処理できる形式に変換
この「内部で処理できる形式」というのはNO.2の回答者様のように
いったんShift-JISに変換するのでしょうか…？

回答No.2

kztk

元ファイルがUTF-16BEであるためにいろいろな便利機能が使えないので、いったんShift-JISへ変換したらよいと思います。
変換にはADODB.StreamのCopyToが使えます。
http://msdn.microsoft.com/ja-jp/library/cc364138.asx

■元ファイルをStreamで読み込み。CharsetはUTF-16BE
■変換先のStreamを作成。CharsetはShift-JIS
■元ファイルのStreamから変換先のStreamへCoptyTo
■変換先のStreamを保存
■変換後のCSVファイルに対してText DriverでSQL発行
　：

あと、先に書いたコードでは以下の要件を見逃していました。その辺はうまくやってください。

>ただし、同じコードが複数のファイルに分かれないようにしたいです。

お礼

ご回答ありがとうございます。
「■変換先のStreamを保存」
まで試してみて変換先のファイルを開いてみたのですが、
UTF-16BE形式になってしまいました。
↓このような書き方をしたのですが間違ってますでしょうか？
Dim sto_in
Set sto_in = WScript.CreateObject("ADODB.Stream")
sto_in.Charset = "UTF-16BE"
sto_in.Open
sto_in.Type = 2
sto_in.LoadFromFile("D:\vbs\test.csv")
sto_in.LineSeparator = -1
sto_in.Position = 0

'変換先Stream作成
Dim sto_out
Set sto_out = CreateObject("ADODB.Stream")
sto_out.Charset = "Shift-JIS"
sto_out.Open
sto_in.CopyTo(sto_out)
sto_in.SaveToFile "D:\vbs\test0001.csv",2
sto_in.Close
Set sto_in = Nothing
Set sto_out = Nothing

回答No.1

kztk

文字コードの制約はなくなったと考えてよいでしょうか。
入出力ともSJISでよい前提として、私ならばこんな感じでしょうか。

■CSVの読み込みにはADOとODBC Text Driverを使用します。
　VBS CSV Text Driver等で検索してみればサンプルが見つかります。

■ソートはCSV読み込み時にSQLで指定するか、ADODB.Recordsetの
　Sortプロパティがたぶん使えます。

■5件づつの出力はただ単にループをまわしながら5件ごとに
　出力ファイルを切り替えていくだけかと思います。

Dim oRst '結果を格納したRecordset
Dim oOutFile '出力ファイル

lCnt = 0
Do While Not oRst.EOF
'5件ごとに出力ファイルを変える。
If lCnt Mod 5 = 0 Then
Set oOutFile = FSO.CreateTextFile("test_out_" & Right("000" & lCnt \ 5 + 1, 3) & ".csv")
End If

'ここの編集が格好悪いですが。。。
oOutFile.WriteLine oRst.Fields(1).Value & "," & ・・・・

lCnt = lCnt+1
oRst.MoveNext
Loop

補足

ご回答ありがとうございます。
丁寧に回答して頂いたのですが、
入力ファイルの文字コードは"UTF-16BE"です…。
肝心なことが質問内容から漏れてしまいました。
大変申し訳ありません。