エクセルファイルの１レコード（１行）を1csvファイルへ変換マクロ

質問

エクセルファイルの１レコード（１行）を1csvファイルへ変換し、エクセルファイルにあるレコード数分だけあるフォルダに自動作成するマクロを教えて下さい。

因みに、csvファイル名は、エクセルデータの『a列.csv』となるようにしたいです。

【例】
本日2007/11/13

○○.xls
A列 B列 C列
111 1 356
13 1 2
・ ・ ・
・ ・ ・

111.CSV
"2007/11/13(火)","1","356,"","",""
13.CSV
"2007/11/13(火)","1","2,"","",""
変換後のcsvの中身は
1列目に、本日の日付
２列目に、１
３列目に、変換元のエクセルファイルの３列目
４、５、６列目に空白
という形式です。

どなたかお分かりになるかた、ご教授願います。

回答No.1

KenKen_SP

> マクロを教えて下さい。

それで、、分らないとこはどこなの？　とか一応言ってみた。。

この手の内容は調べればすぐサンプルありそうです。Open ステート
メント辺りをキーワードで調べてみて下さい。下記は、TextStream
を使いましたけど、たいして変わりません。

A 列にファイル名に使用できない文字があるとか、同名ファイルが
有った場合はどうするのかとか、本当はもっとしっかりと仕様を決め、
エラートラップしないといけないのですが、とりあえず動く程度の
ものです。ご参考までに。

Sub SampleProc()

　　Const DQ = """"
　　Const ForWriting As Long = 2

　　Dim fso　　　　 As Object ' // FileSystemObject
　　Dim ts　　　　　As Object ' // TextStream
　　Dim sDir　　　　As String
　　Dim sBaseName　 As String
　　Dim sFileName　 As String
　　Dim i　　　　　 As Long
　　Dim Buf()　　　 As String

　　Set fso = CreateObject("Scripting.FileSystemObject")

　　' // 保存フォルダのパス
　　sDir = ActiveWorkbook.Path
　　' // データ読み込み開始行（行カウンタ）
　　i = 1
　　' // A 列が空になるまでループ
　　Do
　　　　' // ファイルのベース名
　　　　sBaseName = Cells(i, "A").Text
　　　　If Len(sBaseName) = 0 Then
　　　　　　Exit Do
　　　　Else
　　　　　　sBaseName = sBaseName & ".csv"
　　　　End If
　　　　' // パスと連結させてファイル名を生成
　　　　sFileName = sDir & "\" & sBaseName
　　　　' // 同名ファイル確認（ホントに確認のみだけど）
　　　　If fso.FileExists(sFileName) Then
　　　　　　MsgBox "同名ファイルあるけど上書きするのだ(・∀・)ノ" & vbLf & _
　　　　　　　　　 "[" & sBaseName & "]", vbInformation
　　　　End If
　　　　' // テキストファイルを開く（作成）
　　　　Set ts = fso.OpenTextFile(Filename:=sFileName, _
　　　　　　　　　　　　　　　　　IOMode:=ForWriting, _
　　　　　　　　　　　　　　　　　Create:=True)
　　　　' // 書き込む内容を準備
　　　　ReDim Buf(5)
　　　　Buf(0) = DQ & Format$(Now(), "yyyy/mm/dd(aaa)") & DQ
　　　　Buf(1) = DQ & Cells(i, "B").Text & DQ
　　　　Buf(2) = DQ & Cells(i, "C").Text & DQ
　　　　Buf(3) = DQ & DQ
　　　　Buf(4) = DQ & DQ
　　　　Buf(5) = DQ & DQ
　　　　' // Join でカンマ区切りに連結してテキスト書き込み
　　　　ts.WriteLine Join$(Buf, ",")
　　　　' // テキストファイルを閉じる
　　　　ts.Close
　　　　' // 行カウンタ加算
　　　　i = i + 1
　　Loop
　　Set ts = Nothing
　　Set fso = Nothing

End Sub

お礼

有難う御座いました！
出来ました！