全シートのテキスト出力マクロ

Option Explicit
' アクティブブック全シートをテキストファイルに書き出すマクロ
Sub BOOK_To_TextFile()
　　Const cnsTitle = "テキストファイル出力処理"
　　Const cnsFilter = "テキストファイル (*.txt;*.dat),*.txt;*.dat"
　　Dim xlAPP　　　 As Application　' Applicationオブジェクト
　　Dim intFF　　　 As Integer　　　' FreeFile値
　　Dim strFileName As String　　　 ' OPENするファイル名(フルパス)
　　Dim vntFileName As Variant　　　' ファイル名受取り用
　　Dim strREC　　　As String　　　 ' 書き出すレコード内容
　　Dim GYO　　　　 As Long　　　　 ' 収容するセルの行
　　Dim KETA　　　　As Long　　　　 ' 収容するセルの桁
　　Dim MaxRow　　　As Long　　　　 ' データが収容された最終行
　　Dim MaxCol　　　As Long　　　　 ' データが収容された最終桁
　　Dim lngREC　　　As Long　　　　 ' レコード件数カウンタ
　　Dim sheet　　　 As Worksheet
　　
　' Applicationオブジェクト取得
　　Set xlAPP = Application
　　
　　If xlAPP.ActiveWorkbook.Name = xlAPP.ThisWorkbook.Name Then
　　　 xlAPP.Dialogs(xlDialogActivate).Show
　　End If
　' 「名前を付けて保存」のダイアログでファイル名の指定を受ける
　　xlAPP.StatusBar = "追記出力するファイル名を指定して下さい。"
　　vntFileName = xlAPP.GetSaveAsFilename(InitialFileName:="SAMPLE.txt", _
　　　　　　　　　　　　　　　　　　　　　FileFilter:=cnsFilter, _
　　　　　　　　　　　　　　　　　　　　　Title:=cnsTitle)
　' キャンセルされた場合はFalseが返るので以降の処理は行なわない
　　If VarType(vntFileName) = vbBoolean Then Exit Sub
　　strFileName = vntFileName
　' FreeFile値の取得(以降この値で入出力する)
　　intFF = FreeFile
　' 指定ファイルをOPEN(追記モード)
　' Open strFileName For Append As #intFF
　' 指定ファイルをOPEN(置換モード)
　　Open strFileName For Output As #intFF
　　
　　For Each sheet In Worksheets
　　　　sheet.Select
　　
　　　' 最後尾の行・カラム位置を求める
　　　　With ActiveSheet.UsedRange
　　　　　　MaxRow = .Find("*", , xlFormulas, , xlByRows, xlPrevious).Row
　　　　　　MaxCol = .Find("*", , xlFormulas, , xlByColumns, xlPrevious).Column
　　　　End With
　　
　　　' シート見出しを出力
　　　　strREC = "≪シート:" & ActiveSheet.Name & "≫"
　　　　Print #intFF, strREC
　　　' 1行目から開始
　　　　GYO = 1
　　　' 最終行まで繰り返す
　　　　Do Until GYO > MaxRow
　　　　　' A列内容をレコードにセット(先頭は1行目)
　　　　　　strREC = Cells(GYO, 1).Value
　　　　　　KETA = 2
　　　　　　Do Until KETA > MaxCol
　　　　　　　　strREC = strREC & Chr(9) & Cells(GYO, KETA).Value
　　　　　　　　KETA = KETA + 1
　　　　　　Loop
　　　　　' 右のタブコードは詰める
　　　　　　Do While Right(strREC, 1) = Chr(9) And Len(strREC) > 0
　　　　　　　 If strREC = Chr(9) Then
　　　　　　　　　 strREC = ""
　　　　　　　 Else
　　　　　　　　　 strREC = Left(strREC, Len(strREC) - 1)
　　　　　　　 End If
　　　　　　Loop
　　　　　' レコード件数カウンタの加算
　　　　　　lngREC = lngREC + 1
　　　　　　xlAPP.StatusBar = "出力中です．．．．(" & lngREC & "レコード目)"
　　　　　' レコードを出力
　　　　　　Print #intFF, strREC
　　　　　' 行を加算
　　　　　　GYO = GYO + 1
　　　　Loop
　　
　　Next sheet
　　
　' 指定ファイルをCLOSE
　　Close #intFF
　　xlAPP.StatusBar = False
　' 終了の表示
　　MsgBox "ファイル出力が完了しました。" & vbCr & _
　　　　"レコード件数=" & lngREC & "件", vbInformation, cnsTitle
End Sub