エクセル VBA テキストファイル書き出す応用？

質問

以下のページより、
http://www.asahi-net.or.jp/~ef2o-inue/vba_o/sub05_110_040.html

Option Explicit

' テキストファイル書き出すサンプル(2)
Sub WRITE_TextFile2()
Const cnsFILENAME = "\SAMPLE.txt"
Dim intFF As Integer ' FreeFile値
Dim strREC As String ' 書き出すレコード内容
Dim GYO As Long ' 収容するセルの行
Dim GYOMAX As Long ' データが収容された最終行

' 最終行の取得
GYOMAX = Range("A65536").End(xlUp).Row
' FreeFile値の取得(以降この値で入出力する)
intFF = FreeFile
' 指定ファイルをOPEN(出力モード)
Open ThisWorkbook.Path & cnsFILENAME For Output As #intFF
' 2行目から開始
GYO = 2
' 最終行まで繰り返す
Do Until GYO > GYOMAX
' A列内容をレコードにセット(先頭は2行目)
strREC = Cells(GYO, 1).Value
' レコードを出力
Print #intFF, strREC
' 行を加算
GYO = GYO + 1
Loop
' 指定ファイルをCLOSE
Close #intFF
End Sub

-------------------------------------------------------------
これを参考にしてテキストファイル書き出すのは出来たのですが、
今回は、ちょっと応用で以下のようにしたいです。

Sheet1のA2～A20までテキストファイル名が書いてあるとします。

また、Sheet2～Sheet20ぐらいまで、各Sheetに文章が入っているとします。

テキストファイルに書きだしたいのですが、

Sheet2の内容は、Sheet1のA2のファイル名
Sheet3の内容は、Sheet1のA3のファイル名
Sheet4の内容は、Sheet1のA4のファイル名

このようにしたいのですが、どのようにすればいいのか教えてください。

よろしくお願います。

回答No.2

keithin · ベストアンサー

もうちょっとシンプルなマクロにして、また用意したデータシートとファイル名の個数が合ってなかった時の対処とかもします。

sub macro1()
　dim i as long
　dim s as long
　worksheets("Sheet1").select

’データシートの巡回
　for s = 2 to worksheets.count
　　if cells(s, "A") = "" then exit sub
　　open thisworkbook.path & "\" & cells(s, "A") & ".txt" for output as #1

　’データの巡回
　　for i = 2 to worksheets(s).range("A65536").end(xlup).row
　　　print #1, worksheets(s).cells(i, "A").value
　　next i
　　close #1
　next s
end sub

お礼

回答ありがとうございます。
思っていることができました。

回答No.1

fred2000

おそらく動くと思います
もしこれでダメでしたら、他の方の回答を頼ってください
私の知識ではこれ以上は無理ですので・・

Option Explicit

' テキストファイル書き出すサンプル(2)
Sub WRITE_TextFile3()
Dim cnsFILENAME As String
Dim intFF As Integer ' FreeFile値
Dim strREC As String ' 書き出すレコード内容
Dim GYO As Long ' 収容するセルの行
Dim GYOMAX As Long ' データが収容された最終行
Dim i As Integer

For i = 2 To 20
Worksheets("Sheet" & i).Select

' 最終行の取得
GYOMAX = Worksheets(i).Range("A65536").End(xlUp).Row

' FreeFile値の取得(以降この値で入出力する)
intFF = FreeFile

' 指定ファイルをOPEN(出力モード)
Open Worksheets("Sheet1").Cells(i, 1).Value & ".txt" For Output As #intFF

' 2行目から開始
GYO = 2

' 最終行まで繰り返す
Do Until GYO > GYOMAX

' A列内容をレコードにセット(先頭は2行目)
strREC = Cells(GYO, 1).Value

' レコードを出力
Print #intFF, strREC

' 行を加算
GYO = GYO + 1

Loop

' 指定ファイルをCLOSE
Close #intFF

Next

End Sub

お礼

回答ありがとうございます。
参考にさせていただきます。