複数のテキストボックス内の文章の一括保存

質問

すみません。教えてください。excelで複数のテキストボックス内の文章だけを＜まとめて一度に＞text fileやxls(csv)fileなどで保存する方法はないでしょうか？現状、テキストボックス内の文章を1つcut&pasteしてひとつのfileにまとめて保存しておりますが、大変なのです。よろしくお願いいたします。

回答No.2

Wendy02 · ベストアンサー

amine さん、こんにちは。

#1 で書いた、

　# それを任意で並べ替えて出力するというのは、例えば、名前の枝番などに
　# 数字を振っていただくようになりますが、
　　　　　↓
＞選択したテキストボックスだけの文章を出力することは可能なのでしょうか？

ご指摘になった方法で問題解消しますね。言われて気が付きました。

以下は、#1 とほとんど同じように見えるけれど、一番、コアになる部分になるテキストボックスのテキストの取り出し方が違うので、共用しても、コードが汚くなるだけでやめました。

Shift キーを押しながらクリックして、複数のテキストボックスを、「出力を希望する順に」選択してください。

'<標準モジュール>
Sub テキスト出力選択()
　'Shift キーを押して、複数のテキストボックスを選択してください。
　Dim Fname As Variant
　Dim myPath As String
　Dim Fno As Integer
　Dim buf As String
　Dim shp As TextBox
　'選択したものは、テキストボックスかチェック
　If TypeName(Selection) <> "DrawingObjects" Then
　　MsgBox "テキストボックスを選択してください。"
　　Exit Sub
　End If
　'デフォルトパス
　myPath = ThisWorkbook.Path & "\"
　'ファイル名の入力
　Fname = Application.InputBox("ファイル名を入れてください", Type:=2)
　If VarType(Fname) = vbBoolean Or Fname = "" Then Exit Sub
　'拡張子
　If InStr(Fname, ".txt") = 0 Then
　　Fname = Fname & ".txt"
　End If
　'同名ファイルのチェック
　If Dir(myPath & Fname) <> "" Then
　　MsgBox "既に同じ名前のファイルがありますので中止します。", vbInformation
　　Exit Sub
　End If
　Fno = FreeFile
　On Error Resume Next
　'テキスト出力
　Open myPath & Fname For Output As #Fno
　With ActiveSheet
　　For Each shp In Selection
　　　If shp.ShapeRange.Type = msoTextBox Then
　　　　buf = shp.Text & vbCrLf
　　　　Print #Fno, buf
　　　End If
　　　buf = ""
　　Next
　End With
　Close #Fno
　If Err() = 0 Then
　　MsgBox "正しく出力できました。"
　　Else
　　MsgBox "障害がありました。" & vbCr & "ErrNo. " & Err.Number
　　Err.Clear
　End If
End Sub

お礼

Wendy02様、ありがとうございました。完璧です！

回答No.1

Wendy02

こんにちは。

お話の内容からすると、VBAしか方法がないのではないかと思います。
ただ、このマクロでは、今のところ、出力の順番のオプションが取り付けられていません。ただ、単に、オートシェイプのテキストボックスが作られた順に出力するようになっています。それを任意で並べ替えて出力するというのは、例えば、名前の枝番などに数字を振っていただくようになりますが、一旦、すべてのテキストボックス名を取得して、1番目を探すようなコードになるので、以下の倍ぐらいのコードになってしまいます。必要でしたら、考えてみます。

Alt + F11 で、Visual Basic Editor 画面を開いて、[挿入]－[標準モジュール]でクリックします。開いた画面に以下を貼り付けます。後は、Alt + F11 で元の画面に戻って、Alt + F8 または、[ツール]－[マクロ]－[マクロ]で、[テキスト出力]を選び、クリックします。

'<標準モジュール>
Sub テキスト出力()
　Dim Fname As Variant
　Dim myPath As String
　Dim Fno As Integer
　Dim buf As String
　Dim shp As Shape
　'デフォルトパス
　myPath = ThisWorkbook.Path & "\"
　'ファイル名の入力
　Fname = Application.InputBox("ファイル名を入れてください", Type:=2)
　If VarType(Fname) = vbBoolean Or Fname = "" Then Exit Sub
　'拡張子
　If InStr(Fname, ".txt") = 0 Then
　　Fname = Fname & ".txt"
　End If
　'同名ファイルのチェック
　If Dir(myPath & Fname) <> "" Then
　　MsgBox "既に同じ名前のファイルがありますので中止します。", vbInformation
　　Exit Sub
　End If
　Fno = FreeFile
　On Error Resume Next
　'テキスト出力
　Open myPath & Fname For Output As #Fno
　With ActiveSheet
　　For Each shp In .Shapes
　　　If shp.Type = msoTextBox Then
　　　　buf = shp.DrawingObject.Text & vbCrLf
　　　　Print #Fno, buf
　　　End If
　　　buf = ""
　　Next
　End With
　Close #Fno
　If Err() = 0 Then
　　MsgBox "正しく出力できました。"
　　Else
　　MsgBox "障害がありました。" & vbCr & "ErrNo. " & Err.Number
　　Err.Clear
　End If
End Sub

お礼

Wendy02様、早々のご回答ありがとうございます。また、いつも有用な回答をありがとうございます。今試してみました。本マクロでも十分すぎるほど役に立ちます。とてもずうずうしいと思うのですが、オプションで、選択したテキストボックスだけの文章を出力することは可能なのでしょうか？お時間がございましたらご回答お願いします。