データのテキストファイル抽出

質問

データの抽出に困っています。

エクセルデータにてA～Lのフィールドに値が入っていて、1000レコード程のデータを
・1レコードずつ
・A列のフィールドをファイル名に
・テキストファイルに出力
・テキストファイルには1レコードを縦に、フィールドごと改行して並べる
上記のようにして作成する必要があります。

今までは、
A B C...K L
となっているデータの列と行を入れ替えて
A
B
C
.
.
K
L
としてテキストファイルを作成し、セルAのフィールドをファイル名にして、
手作業で1列ごとにコピー&ペーストして行っていました。

非常に効率が悪いので、全自動化もしくは一部自動化出来ないかと試行錯誤していますが
良い方法が見つけられません。

何か良い方法をご存知の方がおりましたら教えて下さい。

回答No.3

okormazd · ベストアンサー

Ano.2
です。
改行されてないところがありました。
日本語のところはそちらにあわせる。

Sub record2text()

Set shr = Workbooks("元のブック名").Sheets("データのあるシート名")

Workbooks.Add
Set wbt = ActiveWorkbook
Set sht = wbt.Sheets(1)

With shr

r = 1　'レコードの先頭行
fname = .Cells(r, 1)
While fname <> ""
sht.Cells.ClearContents
c = 1
fld = .Cells(r, c)
rt = 1
While fld <> ""
sht.Cells(rt, 1) = fld
rt = rt + 1
c = c + 1
fld = .Cells(r, c)
Wend

Application.DisplayAlerts = False
wbt.SaveAs Filename:= _
"保存先パス" & fname & ".txt", FileFormat:=xlText
Application.DisplayAlerts = True

r = r + 1
fname = .Cells(r, 1)
Wend

End With

Application.DisplayAlerts = false
wbt.Close
Application.DisplayAlerts = True

End Sub

お礼

ありがとうございます！
完璧でした。

回答No.2

okormazd

下記のでどうか。

Sub record2text()

Set shr = Workbooks("元のブック名").Sheets("データのあるシート名")

Workbooks.Add
Set wbt = ActiveWorkbook
Set sht = wbt.Sheets(1)

With shr

r = 1　'レコードの先頭行
fname = .Cells(r, 1)
While fname <> ""
sht.Cells.ClearContents
c = 1 fld = .Cells(r, c)
rt = 1
While fld <> ""
sht.Cells(rt, 1) = fld
rt = rt + 1
c = c + 1
fld = .Cells(r, c)
Wend

Application.DisplayAlerts = False
wbt.SaveAs Filename:= _
"保存先パス" & fname & ".txt", FileFormat:=xlText
Application.DisplayAlerts = True

r = r + 1
fname = .Cells(r, 1)
Wend

End With

Application.DisplayAlerts = false
wbt.Close
Application.DisplayAlerts = True

End Sub

回答No.1

golgo1013

VBAなどで作成するようになると思いますが、下記のサイトを参照にしてVBAで作成してみてはいかがでしょうか？
テキストデータやファイル操作（テキストデータの書き出し）
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_040.html