エクセルVBA テキストに出力、名前を付けて保存

エクセルVBA テキストに出力、名前を付けて保存
　　 A　　B　　 C　　　D
1　 aa　　bb　　cc　　=A1&B1&C1
2　 dd　　ee　　ff　　=A2&B2&C2
3　 gg　　hh　　ii　　=A3&B3&C3


上記エクセルのD列の内容(セルA1～C3が連続したもの)を１行毎にテキストに出力し、
B列の内容をファイル名にしてテキストファイルを多量に自動生成したいのです。

上記エクセルのように３行なら下記の３つのファイルが生成されるといったVBAがほしいのです。

ファイル名がbb.txtで、テキストの内容はaabbcc。
ファイル名がee.txtで、テキストの内容はddeeff。
ファイル名がhh.txtで、テキストの内容はgghhii。


実際は数千行あるので、数千ファイルを一気に生成させたいのです。

どうぞよろしくお願いいたします。

No.2 ベストアンサー 回答者： Wendy02 回答日時： 2010/09/23 12:38

1>1　 aa　　bb　　cc　　=A1&B1&C1　

2>実際は数千行あるので、数千ファイルを一気に生成させたいのです。

3>ファイル名がbb.txtで、テキストの内容はaabbcc。

ちょっと説明不足のような気もしますが、このままで出力したら、必ず、同じものが出てきてしまいます。それを考慮して作れば、以下のようになります。

'//
Sub TestMacro()
　Dim i As Long, k As Variant, j As Long
　Dim fn As String
　Dim mPath As String
　Dim rng As Range, ar As Variant
　Dim buf As String
　Set rng = Range("A1", Cells(Rows.Count, 1).End(xlUp).Offset(, 2))
　
　mPath = CurDir 'パスを決める（CurDir は、カレントディレクトリ）
　
　ar = rng.Value
　For i = 1 To rng.Rows.Count
　　fn = ar(i, 2) & ".txt"
　　Do Until Dir(mPath & "\" & fn) = ""
　　　k = Val(k) + 1
　　　j = InStr(1, fn, "(", 1)
　　　If j > 0 Then
　　　　fn = Mid(fn, 1, j - 1) & "(" & k & ")" & ".txt"
　　　Else
　　　　fn = Replace(fn, ".txt", "", , , 1) & "(" & k & ")" & ".txt"
　　　End If
　　Loop
　　Open fn For Output As #1
　　Print #1, ar(i, 1) & ar(i, 2) & ar(i, 3)
　　Close #1
　　k = ""
　Next
　If Len(buf) > 2 Then
　　MsgBox Mid(buf, 2) & vbCrLf & "重複のため保存は省かれました。"
　Else
　　MsgBox mPath & "に出力されました。"
　End If
End Sub

この回答へのお礼

色々考慮までしただいてとても嬉しく思います！

動作確認できました^^

ありがとうございます！

お礼日時：2010/09/23 13:15

No.3 回答者： jcctaira 回答日時： 2010/09/23 13:16

Sub CSV出力()

　　Const 出力フォルダ = "C:\DATA\?.txt"
　　Dim I As Long
　　For I = 1 To Cells(Rows.Count, "A").End(xlUp).Row
　　　　Open Replace(出力フォルダ, "?", Cells(I, "B")) For Output As #1
　　　　Print #1, Cells(I, "D")
　　　　Close #1
　　Next I
End Sub

※出力フォルダは変更してください。

No.1 回答者： BookerL 回答日時： 2010/09/23 10:54

　とりあえず書いてみたものです。

"c:\test\"　のところを、実際に保存するディレクトリ名に変えてください。

エラー対策や、高速化は考えていませんので、あしからず。


Sub test()
Dim r As Integer
Dim FlName As String
Dim wb As Workbook
Const DirName = "c:\test\" '保存するディレクトリ

Application.DisplayAlerts = False

r = 1
While Cells(r, 2).Value <> ""
Set wb = Workbooks.Add
wb.Worksheets(1).Range("A1").Value = Cells(r, 4)
FlName = DirName & Cells(r, 2).Value & ".txt"
wb.SaveAs Filename:=FlName, FileFormat:=xlText
wb.Close
r = r + 1
Wend

Application.DisplayAlerts = True

End Sub

この回答への補足

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

tada、オートメーションエラーとのメッセージがでてきました。。。

デバッグでは

wb.SaveAs Filename:=FlName, FileFormat:=xlText

の箇所が黄色で表示されました。

エラーの意味がよくわからないので困っています。

一応testフォルダは作成してあります。ＥＸ2007です

勉強の意味でも、補足していただければとても助かります。

宜しくお願いします。

補足日時：2010/09/23 13:19