VBAでタブ区切りテキストの保存に関して

VBAでタブ区切りテキストの保存のプログラムを書くためには

Application.DisplayAlerts = False

Sheets("sheet01").Copy
ActiveWorkbook.SaveAs Filename:="D:\test.txt", FileFormat:=xlText
ActiveWindow.Close

Application.DisplayAlerts = True


という記述が一般的に使われます。

いま、あるプログラムでexcelシート上に

title
subtitle
001　　002　　003
333　　444　　555
666　　777　　888

ような内容が書き込まれたものをタブ区切りで出力したいのですが、
上記の方法で出力すると、
titleやsubtitleと書かれた行の右側にも空白のタブ区切りが一緒に保存されてしまいます。

あるプログラムで読み込ませるためには、
この二つの行のタブ区切りをいちいち消す必要があり、毎回手作業でするのは面倒です。

VBAでこのようなタブ区切りの有無を行ごとに指定して保存するようなことは可能でしょうか？

No.1 ベストアンサー 回答者： Hayashi_Trek 回答日時： 2013/01/30 18:34

データが、1行目2行目は1列、３行目以降に３列のみあるなら

以下のような感じで書けます。
３行目以降の行を最大10列目まで見ながらファイル出力します。


Dim row As Integer
Dim col As Integer
Dim mySht As Worksheet
Set mySht = Sheets("sheet01")
Open "D:\test.txt" For Output As #1
print #1,mySht.Cell(1,1).Text
print #1,mySht.Cell(2,1).Text
row = 3
Do
If mySht.Cell(row,1).Text = "" Then Exit Do '1列目が空欄ならループを抜ける
For col=1 To 10 '最大10列目まで見る
If mySht.Cell(row,col).Text = "" Then Exit For 'col列目が空欄なら次の行へ
If 1 < col Then '2列目以降ならタブを入れる
print #1,vbTab;
End If
print #1,mySht.Cell(row,col).Text;
Next col
print #1,""
row = row + 1
Loop
Close #1

No.3 回答者： DOUGLAS_ 回答日時： 2013/01/30 21:20

#2 DOUGLAS_ です。

Sheets("sheet01").Copy
が抜けておりましたので、
ActiveSheet.UsedRange.Copy
の前にでも入れてください。

No.2 回答者： DOUGLAS_ 回答日時： 2013/01/30 21:15

＞あるプログラムで読み込ませるためには、

＞この二つの行のタブ区切りをいちいち消す必要があり、
＞毎回手作業でするのは面倒です。
　お疲れさまです。

　「D:\test.txt」に対しての書き込みの方法もさることながら、「一緒に保存されてしま」う「右側にも空白のタブ区切り」を削除する方法が、いろいろとあろうかと存じます。

　お示しのコードは、シートごとテキストファイルに保存する方法ですが、下記は、
１）セル範囲をクリップボードに格納し、
２）クリップボードに格納されたデータの中から「タブ＋改行」の文字列を「改行」に置換して、
３）「D:\test.txt」を開いて、ペーストして保存する。
という方法です。

　「vbTab」・「vbNewLine」は「タブ」・「改行」の意味ですので「Chr(9)」・「Chr(13)」でも構いません。

Sub Macro1()
　　Dim objCB As Object　　　　　　　 'IDataAutoWrapper
　　Dim objFso As Variant　　　　　　 'FileSystemObject
　　Const ForWriting As Integer = 2
　　Dim objFile As Variant　　　　　　'TextStream

　　Set objCB = GetObject("new:" & "1C3B4210-F441-11CE-B9EA-00AA006B1A69")
　　Set objFso = CreateObject("Scripting.FileSystemObject")
　　Set objFile = objFso.OpenTextFile("D:\test.txt", ForWriting, True)

　　ActiveSheet.UsedRange.Copy
　　With objCB
　　　　.GetFromClipboard
　　　　Do
　　　　　　.SetText Replace(.GetText, vbTab & vbNewLine, vbNewLine)
　　　　　　.PutInClipboard
　　　　Loop Until InStr(.GetText, vbTab & vbNewLine) = 0
　　　　objFile.Write .GetText
　　End With
　　objFile.Close
　　Application.CutCopyMode = False
　　ActiveWindow.Close SaveChanges:=False
　　Set objFile = Nothing
　　Set objFso = Nothing
　　Set objCB = Nothing
End Sub