エクセルのマクロでワードアートのテキスト抽出

質問

一つのブックのすべてのシートにワードアート（何重かにグループ化）になっているテキストが複数あります。
そのワードアートのテキストを新しいシートを作ってテキストと貼り付けたいのですが、はたしてこんなのはマクロで可能なのでしょうか？
AシートのワードアートのテキストをAシートの右となりに新シートを作ってその中にテキストを貼り付けるイメージです。、、、Bシート,Cシート・・と続く。

回答No.1

KenKen_SP · ベストアンサー

> はたしてこんなのはマクロで可能なのでしょうか？

VBA の質問なら、自分でどこまでやって何を調べたかを提示
した方が良いのでは？

　# 丸投げが好まれないのは当然ありますが、一方で回答者は
　# 質問者のスキルが予測できます。回答の仕方も変わってくる
　# ということです。

■ ポイント

　1. シェープがワードアートかどうか？
　　 Type プロパティーの値が msoTextEffect かどうかで判定。
　2. シェープがグループ化されているか
　　 GroupItems.Count がエラーになるかどうかで判定。
　3. シェープの多重グループ化
　　 単一シェープの情報取得サブプロシージャを作成して、
　　 その中で 上述2. のグループ化判定を行い、グループ化
　　 されていれば再帰処理すれば良い。

分からない部分はネットや参考書で調べ、適当に希望どおりの
動作となるよう作り込んでみて下さい。

以下ソースはシート名などの情報もついでに調べてます。

’ 貼り付け先は標準モジュール
’ テストはほとんどしてません

Option Explicit

Private g_Buf() As String
Private g_Cnt　 As Long

' // 全ワークシート内に配置されたワードアートの情報取得
'
Public Sub EnumWordArtInfo()

　　' 初期化
　　g_Cnt = -1

　　Dim wb　As Workbook
　　Dim sh　As Worksheet
　　Dim shp As Shape

　　Set wb = ActiveWorkbook
　　For Each sh In wb.Worksheets
　　　　For Each shp In sh.Shapes
　　　　　　Call pvGetWordArtInfo(shp)
　　　　Next
　　Next

　　If g_Cnt >= 0 Then
　　　　Dim buf As Variant
　　　　buf = Application.Transpose(g_Buf)
　　　　Set sh = wb.Worksheets.Add(After:=wb.Worksheets( _
　　　　　　　　　　　　　　　　　　　　　wb.Worksheets.Count))
　　　　With sh.Range("A1:E1")
　　　　　　.Value = Array("SheetName", "Address", "GroupName", _
　　　　　　　　　　　　　 "ShapeName", "Text")
　　　　　　.Font.Bold = True
　　　　End With
　　　　sh.Range("A2").Resize(UBound(buf), UBound(buf, 2)).Value = buf
　　　　sh.Range("A:D").EntireColumn.AutoFit

　　Else
　　　　MsgBox "ワードアートが無い？", vbInformation
　　End If

　　Erase g_Buf, buf
　　Set sh = Nothing
　　Set wb = Nothing

End Sub

Private Sub pvGetWordArtInfo(ByRef shp As Shape, _
　　　　　　　　　　　　　　 Optional ByVal sGroupName As String _
)

　　On Error Resume Next
　　Dim n As Long
　　n = shp.GroupItems.Count
　　If Err.Number = 0 Then
　　　　' グループ化されたシェープの場合は再帰処理する
　　　　On Error GoTo 0
　　　　Dim i As Long
　　　　For i = 1 To n
　　　　　　Call pvGetWordArtInfo(shp.GroupItems.Item(i), shp.Name)
　　　　Next i
　　Else
　　　　' グループ化されていない場合
　　　　Err.Clear
　　　　If shp.Type = msoTextEffect Then
　　　　　　' ワードアート各種情報取得
　　　　　　g_Cnt = g_Cnt + 1
　　　　　　ReDim Preserve g_Buf(4, g_Cnt)
　　　　　　g_Buf(0, g_Cnt) = shp.Parent.Name　　　' シート名
　　　　　　g_Buf(1, g_Cnt) = Range(shp.TopLeftCell, _
　　　　　　　　　　　　　　　　　　shp.BottomRightCell).Address ' 配置位置
　　　　　　g_Buf(2, g_Cnt) = sGroupName　　　　　 ' グループ名
　　　　　　g_Buf(3, g_Cnt) = shp.Name　　　　　　 ' シェープ名
　　　　　　g_Buf(4, g_Cnt) = shp.TextEffect.Text　' テキスト
　　　　End If
　　End If

End Sub

お礼

正直できるとは思いませんでした・・・すごいとしかいいようがありません。。。
ソースを見てもわからないことだらけですので、1から時間をかけて勉強します。本当にありがとうございました。