エクセルマクロ（ＶＢＡ）でテキストに出力、3つのテキストファイルに名前を付けて保存するには

Question

エクセルマクロ（ＶＢＡ）超初心者です。
エクセルシート内の3か所の指定範囲内の複数セル内の文字列をtxt形式でぞれぞれ3つのtxtファイル書き出して保存したいのですが、どのような記述がよろしいでしょうか。
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
	A	B	C
1	＜範囲1＞		
2	aa	bb	cc
3	dd	ee	ff
4	＜範囲2＞		
5	gg	hh	ii
6	jj	kk	ll
7	mm	nn	oo
8	＜範囲3＞		
9	pp	qq	rr
10	ss	tt	uu
11	vv	ww	xx
12	yy	zz	aa
－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－－
要望

（１）指定範囲は3か所で、セルの場所は不変。
＜範囲1＞はA2～C3
＜範囲2＞はA5～C7
＜範囲3＞はA9～C12

（２）書き出されたtxtは改行削除、タブ削除がなされた状態にする。
＜範囲1＞はaabbccddeeff
＜範囲2＞はgghhiijjkkllmmnnoo
＜範囲3＞はppqqrrssttuuvvwwxxyyzzaa

（３）保存する.txtファイルは常に固定のファイル名でそれぞれ保存。
＜範囲1＞はD:\hogehoge\1.txt
＜範囲2＞はD:\hogehoge\2.txt
＜範囲3＞はD:\hogehoge\3.txt

※セル内の文字列は他のシートのデータを参照しエクセル関数によって
導かれたものです。
この文字列の内容は毎回変わります。
他のシートのデータを更新したあと、一度の処理実行で上記3ファイルが
書き出されることで業務を効率化させたいと考えています。
この業務はほぼ毎日のように発生する繰り返し業務のため、
エクセルマクロ（ＶＢＡ）による効果は大きいと思います。

WindFaller · Accepted Answer

こんにちは。

>それぞれマクロ内に事前に記述した任意のファイル名を付けるように
>したい場合はどうすればいいでしょうか。

ある程度は、想定していました。簡単に直すとこのようになります。
一応、もう一つの想定事項を書いておくと、上書きではなく「追加の書き込み」ということでした。ふだん、私は、今回のようなマクロにしないのですが、気になったので、そういうコードにしました。

本題に戻りますと、
Fnames = Array("abc", "def", "xyz")　'ここに拡張子なしでファイル名を書き込みます。
修正点は2つです。

なお、念の為に書いておきますと、
ar = Array(Range("A2:C3"), Range("A5:C7"), Range("A9:C12"))
こちらのセルの範囲が3つなって、3回分のファイルが作られますから、ファイル名は3つないといけません。4つにするためには、ファイル名も当然、4つがないといけません。

もう一つ、念のためですが、出力は、SJISになっていますが、オプションを加えることで、UNICODEの変更も可能です。

'//
Sub ExportTextR()
　'No. 9054919
　Dim objFS As Object
　Dim objFolder As Object
　Dim objFile As Object
　Dim buf As String
　Dim c As Variant, i As Long
　Dim ar As Variant
　Dim Fnames As Variant
　'----設定----
　Const MYPATH = "D:\hogehoge\" '末尾には、￥を入れてください。
　'A2～C3,A5～C7,A9～C12
　ar = Array(Range("A2:C3"), Range("A5:C7"), Range("A9:C12"))
　'出力ファイル名
　Fnames = Array("abc", "def", "xyz")　'←修正点(ここにファイル名を書き込む)
　'----設定終---
　Set objFS = CreateObject("Scripting.FilesystemObject")
　If objFS.FolderExists(MYPATH) = False Then
　　MsgBox MYPATH & "というフォルダーは存在しません", vbExclamation: Exit Sub
　Else
　　Set objFolder = objFS.GetFolder(MYPATH)
　End If
　For i = 0 To UBound(ar)
　　For Each c In ar(i)
　　　buf = buf & c.Text 'テキストプロパティにしている
　　Next c
　　Set objFile = objFolder.CreateTextFile(Fnames(i) & ".txt") '←修正点
　　objFile.Write buf
　　buf = ""
　　objFile.Close
　Next i
End Sub
'///

WindFaller · Answer

こんにちは。

>記号、2バイト文字ともURLエンコードされない形でUTF-8出力する方法はありますでしょうか。
>こちらはVBAの守備範囲からはずれてくるかもわかりませんが。
失礼しました。記号化することかと思っていましたので、間違えました。もちろん、Web系のVBAを扱う人なら、これは守備範囲です。UTF-8変換の意図が分からなかったからです。たぶん、問題ないと思います。

一応、ツギハギで間違えるといけないので、全文を改めて出しておきます。

'//
Sub ExportTextR2()
No. 9054919－3　obj型UTF-8変換
　Dim objFS As Object
　Dim objFolder As Object
　Dim objFile As Object
　Dim buf As String
　Dim c As Variant, i As Long
　Dim ar As Variant
　Dim Fnames As Variant
　Dim fn As String
　'----設定----
　Const MYPATH = "D:\hogehoge\" '末尾には、￥を入れてください。
　'A2～C3,A5～C7,A9～C12
　ar = Array(Range("A2:C3"), Range("A5:C7"), Range("A9:C12"))
　'出力ファイル名
　Fnames = Array("abc", "def", "xyz")
　'----設定終---
　Set objFS = CreateObject("Scripting.FilesystemObject")
　If objFS.FolderExists(MYPATH) = False Then
　　MsgBox MYPATH & "というフォルダーは存在しません", vbExclamation: Exit Sub
　Else
　　Set objFolder = objFS.GetFolder(MYPATH)
　End If
　For i = 0 To UBound(ar)
　　For Each c In ar(i)
　　　buf = buf & c.Text 'テキストプロパティにしている
　　Next c　　
　　fn = Fnames(i) & ".txt"
　　Set objFile = objFolder.CreateTextFile(fn)
　　objFile.Write buf
　　buf = ""
　　objFile.Close
　　Call objSJis2Utf8(fn)
　Next i
End Sub
Private Sub objSJis2Utf8(Fname As String)
Dim objSrc As Object 'ADODB.Stream
Dim objDst As Object ' ADODB.Stream
　Set objSrc = CreateObject("ADODB.Stream")
　　With objSrc
　　　　.Type = 2 ' adTypeText
　　　　.Open
　　　　.Charset = "shift-jis"
　　　　.LoadFromFile Fname
　　　　.Position = 0
　　End With
　　Set objDst = CreateObject("ADODB.Stream")
　　With objDst
　　　　.Type = 2
　　　　.Open
　　　　.Charset = "utf-8"
　　　　.Type = 2　'adTypeText
　　End With
　　objSrc.CopyTo objDst
　　objDst.Position = 0
　　objDst.savetofile Fname, 2
End Sub
'///

WindFaller · Answer

こんばんは。

コードの下から見ていって、Next c という所の後に、
　 buf = strEncodeUtf8(buf)　'UTF8に変換
　という行を加えてあげ、エンコード用のユーザー定義関数を加えてあげればできます。
　
・
・
・
　For i = 0 To UBound(ar)
　　For Each c In ar(i)
　　　buf = buf & c.Text 'テキストプロパティにしている
　　Next c
　　buf = strEncodeUtf8(buf)　'UTF8に変換　◎ココ
　　Debug.Print buf
　　Set objFile = objFolder.CreateTextFile(Fnames(i) & ".txt")
　　objFile.Write buf
　　buf = ""
　　objFile.Close
　Next i
End Sub

'ユーザー定義関数
Private Function strEncodeUtf8(ByVal strSource As String) As String
　Dim objSC As Object
　Set objSC = CreateObject("ScriptControl")
　objSC.Language = "Jscript"
　strEncodeUtf8 = objSC.CodeObject.encodeURIComponent(strSource)
　Set objSC = Nothing
End Function

'もし、あちこちでこの関数を使うようでしたら、Private から、Public に直してあげるとよいです。

WindFaller · Answer

こんにちは。

上書き更新でよいのでしょうか？
それなら、以下のようにすればよいです。都合で、全部FileSystemObject からみにしてしまいました。
出力の最後には、Enterキーが入っていませんので、もし、加工したりする場合は、vbCrLf などを最後に付け加えてやらないといけません。

'//
Sub ExportText()
　Dim objFS As Object
　Dim objFolder As Object
　Dim objFile As Object
　Dim buf As String
　Dim c As Variant, i As Long
　Dim ar As Variant
　'----設定----
　Const MYPATH = "D:\hogehoge\" '末尾には、￥を入れてください。
　'A2～C3,A5～C7,A9～C12
　ar = Array(Range("A2:C3"), Range("A5:C7"), Range("A9:C12"))
　'----設定終---
　Set objFS = CreateObject("Scripting.FilesystemObject")
　If objFS.FolderExists(MYPATH) = False Then
　　MsgBox MYPATH & "というフォルダーは存在しません", vbExclamation: Exit Sub
　Else
　　Set objFolder = objFS.GetFolder(MYPATH)
　End If
　For i = 0 To UBound(ar)
　　For Each c In ar(i)
　　　buf = buf & c.Text 'テキストプロパティにしている
　　Next c
　　Set objFile = objFolder.CreateTextFile(CStr(i + 1) & ".txt")
　　objFile.Write buf
　　buf = ""
　　objFile.Close
　Next i
End Sub
'///

エクセルマクロ（ＶＢＡ）でテキストに出力、3つのテキストファイルに名前を付けて保存するには

こんにちは。

こんにちは。

こんばんは。

こんにちは。

このQ&Aを見た人はこんなQ&Aも見ています

関連するカテゴリからQ&Aを探す

このQ&Aを見た人がよく見るQ&A

デイリーランキングこのカテゴリの人気デイリーQ&Aランキング

マンスリーランキングこのカテゴリの人気マンスリーQ&Aランキング