ワードアートをテキスト（セル）に変換

質問

こんにちは。上手く説明できないかもしれませんが。。
エクセルの表データをテキストデータへ
変換したいのですが、
そのエクセルデータが、
一つ一つのセルの上にワードアートで文字が入っている状態で、列や行毎のコピーが出来ずに困っています。
かなりの数があるので、一つ一つコピペするのは
大変な時間がかかるので
どうにか解決方法はあるでしょうか？
どなたかご存じであればよろしくおねがいいたします。
OSはwindowsxp office2003に
他はMacOS　10.3／9.2で
それぞれオフィス98、x
があります。

回答No.1

Wendy02 · ベストアンサー

もしも、きちんと、ワードアートが並んでいるものでしたら、以下のマクロで動きます。

最初に、写したい「ワードアートのあるシート」を開いておいて、

ツール－マクロ－Visual Basic Editor
で、挿入－標準モジュールで、開いた白い画面に、以下を貼り付けて
上のメニューのツールに、「▲　〓　■」があったら、「▲」をクリックしてみてください。(三角は横になっています） ない場合は、メニューの実行－Sub/..の実行　をクリックしてみてください。

'注意:以下は、Sheet2 になっていますので、必要な場合は、任意の場所に書き換えてください。

Sub textEffectCopy()
Dim shp As Shape
For Each shp In ActiveSheet.shapes
　If shp.Type = msoTextEffect Then
　'コピー先
　 Worksheets("Sheet2").Range(shp.TopLeftCell.Address).Value = _
　　　　　shp.TextEffect.Text
　End If
Next
End Sub

ただし、重なり合っている場合は、上書きされることがあります。

補足

ご回答ありがとうございます。
すいません、確認してみたら、ワードアートではなく、テキストボックスでした。。
その場合でも上記と同じような設定でも大丈夫でしょうか？
また、微妙に重なりあっているものが多数あるのですが、その場合回避法などはありますか？
もし、よろしければ御教授願えたらと思います。

回答No.7

Wendy02

kuragemamaさん、こんばんは。

＞マクロを実行すると
＞abcd01200345efgh1220ijklme0002020jikme00020
＞と1つのセルに表示されるので、

区切りの空白が入りませんでしたか？入れたつもりでしたけれど。
もし、空白の代わりに、「,」（コンマ）を入れるのでしたら、

If .Exists(KeyAddress) = False Then
　　 .Add KeyAddress, myItem
　　 Else
　　 .Item(KeyAddress) = .Item(KeyAddress) & myItem
　　End If
　 End If

そこに、コンマ(,) 入りなど入れるのでしたら、
　 .Item(KeyAddress) = myItem　& "," & .Item(KeyAddress)
とします。

今回、どのぐらいの列になるのか予想できなかったせいでもあるのです。
その後で、コンマや空白区切りを、その行の横のセル列に割り当てる方法も考えています。ただし、その元の出力したデータの列数がいくつになるか教えていただいたほうが、うまく行きます。

お礼

すぐにお返事をさしあげたのですが、お礼がきちんと反映されていなかったみたいで、私も確認しておらず、申し訳ありませんでした。
列数は1日1列の1ヵ月なので、30列か31列になります。
細かく確認してみたところ、「,」区切りなどを入れてみても、重なっているテキストボックスには、きちんと反映されないようです。
空白は、テキストボックス内の改行に空白が設けられるようです。
それでもかなり便利になって、なんとか締切りに間に合いました！ありがとうございます。
時間ができたので、VBAの本を買ってきました！こちらのほうでも色々と試行錯誤しながら頑張ってみたいと思います。本当に感謝しています。ありがとうございます。

回答No.6

Wendy02

＞コンパイルエラー
そこに出てくるのは、私のコードではありませんね。（^^;
そのコードを見た限りでは、同じことをしていたようですね。
それですと、一列に、ずっと下に出てきてしまいます。
そういう形を望んでいたとしたら、ちょっと私のほうは、不安になりますね。
私のは、もっと手の込んだことをしていますから。

＞プロシージャの外では無効です。とメッセージが出て
それは、何かの残骸のようです。Sub ～End Sub　の外にあるもので、構文は全てエラーになります。それで、当面、「'」をつけてくださればよいかと思います。不要でしたら、削除してください。

'Dim ws As Worksheet
'Dim c As Shapes
'Dim s As Shape
'---------------ここから以下がエラーの元ですが、
私としては、プロシージャ外にある宣言(Dim)も、同じ、モジュール内にそういうものがあると、誤動作の元になりますので、すべて処理してください。ただ、私のは、すべてローカル変数で行っていますので大丈夫のはずです。

もし、ツールバーの上に、白い手のマーク、水色の「〓」のマーク、「〓←マーク付き」がありましたら、

不要範囲をマウスで選択して、真中の水色の「〓」マークをクリックすれば、いっぺんに「'」がつきます。

そうすると、一行が全部緑色の文字になり、影響を及ぼさなくなります。

お礼

すいません。よくわからないまま色々なコードで試していたせいのようです。
改めて、試してみたところ、問題なく実行ができました。詳しい御説明していただき、私には難しいことだらけですが、この作業を終わらさないといけないので、落ち着いたら、しっかりと勉強する意欲がわいてきました！とても感謝しています。本当にありがとうございます！

回答No.5

Wendy02

＞テキストボックス自体もテキストが隠れていたりする部分も多く、印刷して確認すら出来ず、これもまた一つ一つ大きさを調整するとなるとかなり厄介です。
それはやっかいですね。
今回、「印刷して確認」ということができるレベルではないし、そのセルに入っているテキストボックス群のひとつひとつが、独立した存在なのか、それとも、ひとつのセルに入れるべきかの判断に迷います。
もしかして、電車やバスの時刻表のようなものなら、あれは、ひとつのセルに入れますね。とりあえず、その線で進めてみました。

前回できあがったものに、細かい部分を手直ししました。
できれば、これは、標準モジュールに貼り付けてください。
ツール－マクロ－Visual Basic **メニュー－挿入－標準モジュール

テキストボックスの入っている場所のシートで起動してください。コピーする先のシートを聞いてきますので、入力してください。
とりあえず、これで様子をみてください。

'------------------------------------------
Option Explicit
Sub TextBoxExtract()
Dim strSH As String
Dim shp As Shape
Dim KeyAddress As String
Dim myItem As String
Dim i As Variant 'Dic のItem
Dim j As Long
Dim objDic As Object
Dim mySh As Worksheet
'
On Error GoTo ErrHandler
strSH = Application.InputBox("シート名を入力" & vbCr & _
"出力されるシートは、コピー前に全て消去されます。", _
"Sheet名", "Sheet2", Type:=2)
'
If Len(strSH) = 0 Then
　MsgBox "シートが選択されていません。", 16
　Exit Sub
ElseIf strSH = "False" Then
　Exit Sub
End If
Set mySh = Worksheets(strSH)
'
With mySh 'コピー先のデフォルト化と消去
　'文字列は消す
　.Cells.ClearContents
　'書式標準
　.Cells.NumberFormat = "General"
　'折り返し表示をなくする
　.Cells.WrapText = False
　'連結はさせない
　.Cells.MergeCells = False
　'セルの高さ幅を標準にする
　.Cells.Rows.RowHeight = .StandardHeight
　.Cells.Columns.ColumnWidth = .StandardWidth
End With
'
　 Set objDic = CreateObject("Scripting.Dictionary")
'
With objDic
　For Each shp In ActiveSheet.shapes
　 If shp.Type = msoTextBox Then
　　KeyAddress = shp.TopLeftCell.Address
　　myItem = VBA.Trim(shp.DrawingObject.Text)
　　If .Exists(KeyAddress) = False Then
　　 .Add KeyAddress, myItem
　　 Else
　　 .Item(KeyAddress) = .Item(KeyAddress) & myItem
　　End If
　 End If
　Next
　For Each i In .keys
　'書式は文字列にします
　 mySh.Range(i).NumberFormatLocal = "@"
　 mySh.Range(i).Value = Replace(.Item(i), vbLf, " ")
　Next i
　For j = 1 To mySh.UsedRange.Columns.Count
　 'セル幅のオートフィット
　 mySh.Columns(j).EntireColumn.AutoFit
　Next
End With
ErrHandler:
　If Err.Number > 0 Then
　 MsgBox "Err: " & Err.Number & "(" & Err.Description & ")"
　 Else
　 mySh.Select
　 MsgBox "終了しました。", 64
　End If
Set objDic = Nothing
Set mySh = Nothing
End Sub

'------------------------------------------

お礼

他のデータで試してみたらちゃんと出来ました！
一つのセルに
（[]=テキストボックス）
[00][abcd012]
[12][345efgh]
[20][20ijklme000]
などと入っていて
マクロを実行すると
abcd01200345efgh1220ijklme0002020jikme00020
と1つのセルに表示されるので、テキストボックスが隠れているため、判断がつきにくいのですが
それでもここまでテキストに変換することができてとてもとても感激です。
ありがとうございます！

補足

こんにちは。本当にお世話になっております。
試してみたところ
コンパイルエラー
プロシージャの外では無効です。とメッセージが出て
下記のコードが現れます。
Dim ws As Worksheet
Dim c As Shapes
Dim s As Shape
Set ws = ActiveSheet
Set c = ws.Shapes
For i = 1 To c.Count
c.Item(i).Select
ws.Cells(i, 1) = Selection.Characters.Text
Next
何かしら原因がおわかりでしたら度々恐縮ですがよろしくおねがいいたします。。

回答No.4

Wendy02

補足説明します。
#なぜ、そうテキストボックスが増えたのか、元の原稿に、空白（スペース）などがあるのではないでしょうか？もしそうだとすると、スペースを入れなくてはなりません。

この説明わかりにくいですよね。

つまり、
ひとつのセルに、

「abc」　「defg」　「123」

のabc,defg,123 が、それぞれテキストボックスがあるとすれば、取り出すときは、
　abc　defg　123
のように戻してあげなくてはならないってことです。
それとも、
　abcdefg123

でよいのか、こちらでは判断がつかないのです。

セルの番地は、そのまま写していきます。

一応、コードは完成しています。

回答No.3

Wendy02

やっと全ての状況が飲み込めました。
もしかして、スキャナーで撮ってOCRで貼り付けたものではありませんか？
本来は、仮にOCRで貼り付けたものであってもなくても、一旦、印刷して、もう一度、ちゃんとしたやり方でやれば、Excelには張り付くのですが、それは、ここでは別の話ですから、それ以上は言いません。

要するに、
＞一つのセルの中に多いところだと3～4組分（6～8個）程入っています。
重なり合ったテキストボックスだとしても、中に見えているものは、一まとめにできるわけではありませんか？グループ化などされていませんよね。
'-------------------------
コードを作っちゃう前に、ちょっと確認です。

なぜ、そうテキストボックスが増えたのか、元の原稿に、空白（スペース）などがあるのではないでしょうか？もしそうだとすると、スペースを入れなくてはなりません。

たぶん、列は列に、まとまってあるものは一つのセルに、テキストとして変更できればよいわけですね。

私の、思い違いでないと良いのですが……。

補足

こんにちは。お返事遅くなってすいません。
データはクライアントからでどういう風に制作をしているのかわからないのですが、これ以外のデータはないとのことで、このデータでやらければいけず、困っている状態です。
また、テキストボックス自体もテキストが隠れていたりする部分も多く、印刷して確認すら出来ず、これもまた一つ一つ大きさを調整するとなるとかなり厄介です。セル一つ一つに入っていれば問題はなかったのですが、セルの一つが30分という単位になっていて、そのなかに細かい分（15、05、20など）名前などが複数組入っている形です。
私もなぜ、こういう作り方をしているのか疑問ですが、名前の部分が字数が多く、複数行になっている場合が多いのでテキストボックスを使用しているものと思われます。
一つのセルに00（時間）横のセルに名前
とできればセル一つ一つに入っていけばベストですが
最終的にテキストデータが欲しいので
時間　名前　
時間　名前...
と時間通りに続いていることが希望です。
説明が下手で恐縮ですがご理解いただけたでしょうか？

回答No.2

Wendy02

テキストボックスというのは、オートシェイプで書かれたものですか？
それを選択すると、左上隅の白い四角に、「四角形」とでますか？

テキストボックスの左上の角が、同じセルに入っている場合は、新たなコードを考えなくてはなりません。とりあえず、以下を試してみてください。
注意事項は、#1 と同じです。

'以下の「Sheet2」 は、任意です。
'------------------------------------
Sub DrawingObjectTextCopy()
Dim shp As Shape
For Each shp In ActiveSheet.shapes
　If shp.Type = msoShapeRectangle Then
　'コピー先
　 Worksheets("Sheet2").Range(shp.TopLeftCell.Address).Value = _
　　　　 shp.DrawingObject.Text
　End If
Next
End Sub
'------------------------------------

補足

オートシェイプでつくられているものです。
が、右上隅の白い四角というのはnameboxのことでしょうか？
それだと、テキスト1、2、などとでてきます。
膨大な数なので全部をチェックはできていませんが、
列の上から下にかけて
テキスト1.2.3...と並んでいるようです。
小さいテキストボックス　00（時間）を覆うようにして●●●●（名前）が入っていて
2つで一組という感じですがそれが
一つのセルの中に多いところだと3～4組分（6～8個）程入っています。

一列は日にち毎に分けられていてそれが1ヵ月（30列）
最終的には
1日
00　●●
00　●●

というようなスケジュールをテキスト形式にしたいと思っています。
下手な説明ですが、また何か解決策がありましたらどうぞよろしくおねがいいたします。