プロが教える店舗&オフィスのセキュリティ対策術

エクセルマクロ(VBA)超初心者です。
エクセルシート内の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
------------------------------------
要望

(1)指定範囲は3か所で、セルの場所は不変。
<範囲1>はA2~C3
<範囲2>はA5~C7
<範囲3>はA9~C12

(2)書き出されたtxtは改行削除、タブ削除がなされた状態にする。
<範囲1>はaabbccddeeff
<範囲2>はgghhiijjkkllmmnnoo
<範囲3>はppqqrrssttuuvvwwxxyyzzaa

(3)保存する.txtファイルは常に固定のファイル名でそれぞれ保存。
<範囲1>はD:\hogehoge\1.txt
<範囲2>はD:\hogehoge\2.txt
<範囲3>はD:\hogehoge\3.txt

※セル内の文字列は他のシートのデータを参照しエクセル関数によって
導かれたものです。
この文字列の内容は毎回変わります。
他のシートのデータを更新したあと、一度の処理実行で上記3ファイルが
書き出されることで業務を効率化させたいと考えています。
この業務はほぼ毎日のように発生する繰り返し業務のため、
エクセルマクロ(VBA)による効果は大きいと思います。

質問者からの補足コメント

  • HAPPY

    ありがとうございました。ご教示いただきました内容でまさに
    希望通りの結果となりました。

    ここで欲が出てきたといいますか・・・・

    (3)で述べた保存する.txtファイル名ですが、1.txt、2.txt、3.txtではなく
    それぞれマクロ内に事前に記述した任意のファイル名を付けるように
    したい場合はどうすればいいでしょうか。


    <範囲1>はD:\hogehoge\abc.txt  '任意のファイル名
    <範囲2>はD:\hogehoge\def.txt  '任意のファイル名
    <範囲3>はD:\hogehoge\xyz.txt  '任意のファイル名

      補足日時:2015/08/30 21:28
  • HAPPY

    WindFallerさん、ありがとうございました。
    うまくいきました。

    > 一応、もう一つの想定事項を書いておくと、上書きではなく「追加の書き込み」
    > ということでした。

    当方の要望は上書き更新ですのでいただいた記述で適合です。

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

    ご指摘ありがとうございました。こちらの事項は思いつきませんでした。
    要望はutf-8出力です。

    書き出した後にフリーソフト等で変換してもいいかとは思いますが、
    こちらも1度の実行でurf-8書き出しまで完了できるとありがたいです。
    オプションを加える場合の記述方法ご教示いただけますでしょうか。
    (当方の「要求仕様」が不十分で2度手間3度手間かけてしまいまして
    すみません。これができましたら要望通りです。)

      補足日時:2015/08/31 15:33
  • うれしい

    WindFallerさん、ありがとうございました。
    (1)2回目の回答でお示しいただきました「For i = 0 To UBound(ar)」以下を
    差し替えてみました。

    書き出されたtxtファイルを文字コード判定ツールで見てみたところ
    shift-jisの判定でした。

    (2)また、記号、2バイト文字(漢字等)がURLエンコードされた文字で出力されます。
    ●出力したい文字(抜粋)
    document.write('<dd class

    ●実際に出力された文字(抜粋)(URLエンコードされた文字となっています)
    document.write('%3Cdd%20class

    記号、2バイト文字ともURLエンコードされない形でUTF-8出力する方法はありますでしょうか。
    何度もすみません。(こちらはVBAの守備範囲からはずれてくるかもわかりませんが。)

      補足日時:2015/08/31 20:30

A 回答 (4件)

こんにちは。



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

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

本題に戻りますと、
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
'///
    • good
    • 0
この回答へのお礼

WindFallerさん
ありがとうございました。
オプションのutf-8出力のほうは当方のやり方がよくないのか、「実行時エラー'3002':ファイルを開けませんでした」のエラーが出ました。

ただし、shift-jis出力で当方は問題ないことがわかりましたのでこちらの回答にてベストアンサーとさせていただきたいと思います。

ありがとうございました。

お礼日時:2015/09/01 14:40

こんにちは。



>記号、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
'///
「エクセルマクロ(VBA)でテキストに出力」の回答画像4
    • good
    • 0

こんばんは。



コードの下から見ていって、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 に直してあげるとよいです。
    • good
    • 0

こんにちは。



上書き更新でよいのでしょうか?
それなら、以下のようにすればよいです。都合で、全部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
'///
    • good
    • 0

お探しのQ&Aが見つからない時は、教えて!gooで質問しましょう!