エクセル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 · ベストアンサー

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

お礼

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

動作確認できました^^

ありがとうございます！

回答No.3

jcctaira

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

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

"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です

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

宜しくお願いします。