VBAでオートシェイプの中に記載した内容（赤字や取り消し線）をそのまま取得する方法について

前提

VBA初心者です。
VBAで現在オートシェイプの中に記載した内容を取得して、
セルのほうに内容をそのまま抽出するプログラムを作成しようとしています。

実現したいこと

オートシェイプの中にある内容をそのまま抜き出したい

ここに実現したいことを箇条書きで書いてください。
・オートシェイプから赤字を抜き出す。
・オートシェイプから取り消し線の文字列を抜き出す。

発生している問題・エラーメッセージ

テキストとして抜き出すことはできているのですべて黒字では抜き出せますが、色がついた状態や取り消し線ごと取得することができないです。

該当のソースコード

なし

試したこと

①targetsheet.Shapes(Z).TextFrame.Characters.Text ⇒黒字として取得は可能だが色や取り消し線は取得できない。
②targetsheet.Shapes(Z).TextFrame.Copy
writeSheet.Range("L" & rcnt).PasteSpecial (xlPasteAll)　⇒代替案オートシェイプごと取得する。

補足情報（FW/ツールのバージョンなど）

EXCELは2013を使用しています。

■ここにより詳細な情報を記載してください。
できれば①で取得したいのですが、無理であればオートシェイプごと取得してくること（②）も考えています。
ただ②の場合も、すべてのオブジェクトを取得して目視で確認するのは難しいので、取り消し線や赤字が含まれているものだけを対象とする条件を追加したいのですが、こちらもうまくいかないです。

上記の内容をかけいつできる方がいらっしゃいましたらご教授いただきたいです。
よろしくお願いいたします。

行動規範の内容に同意します

回答2件

VBAで現在オートシェイプの中に記載した内容を取得して、
セルのほうに内容をそのまま抽出する

色がついた状態や取り消し線ごと取得する

Excel.Range オブジェクトの PasteSpecial メソッドではなく、
Excel.Worksheet オブジェクトの PasteSpecial メソッドを
使用なさればよろしいでしょう。

vba
1Private Sub test()
2
3    Dim TargetSheet As Worksheet
4    Dim TargetShape As Excel.Shape
5    Dim OutputRow As Long
6    
7    Set TargetSheet = ThisWorkbook.Worksheets(1)
8    
9    With TargetSheet
10        
11        If .Shapes.Count = 0 Then
12            Exit Sub
13        End If
14        
15        OutputRow = 0
16        
17        For Each TargetShape In .Shapes
18            If TargetShape.TextFrame2.HasText = True Then
19                TargetShape.TextFrame2.TextRange.Copy
20                OutputRow = OutputRow + 1
21                .Cells(OutputRow, "L").Select
22                .PasteSpecial Format:="HTML", Link:=False
23            End If
24        Next
25    
26    End With
27    
28    Set TargetSheet = Nothing
29    
30End Sub

但し、コピーされたテキストに改行文字が含まれている場合は
各行のテキストが別々のセルに出力されることになります。

投稿2023/01/16 06:35

sk.exe

総合スコア1066

celsius710

2023/01/16 14:07 編集

回答いただきありがとうございます。頂いたコードをもとに現在考察中です。まだ解決できていないためまた改めて返事させていただきます。エラーは出ないのですが、 .PasteSpecial Format:="HTML", Link:=Falseの箇所をデバッグで確認したのですが値を貼り付けできず空白のままで取得できていないので現在原因を探っています。

pig_vba

2023/01/16 17:33

実は貼り付け自体はその手法でできるのですが、コピーができません。taxtRange.Copyでクリップボードに保存される情報がセルに対応してないからです。コピー側は手動操作でもマクロの記録が行われないため、最悪文字だけ転記して書式情報をあとからセル側に再設定するしかないかなって思ってます

celsius710

2023/01/17 00:12

pig_vbaさん回答ありがとうございます。メソッドがセルに対応してないなどの制約がVBAにはあるんですね。初心者ですのでそのあたり自分の力では解決に時間がかかったと思いますので教えていただけて非常に助かりました。文字列だけ転記して書式情報をあとから再設定という方法について私も同様に考えたのですが、実装の仕方がまだ私の力では分からず断念しました。pig_vbaさんに提示いただいた方法で再度検討します。ありがとうございました。以降はpig_vbaさんの提示いただいた方向に返信いたします。

sk.exe

2023/01/17 01:04

> 実は貼り付け自体はその手法でできるのですが、コピーができません。 > taxtRange.Copyでクリップボードに保存される情報がセルに対応してないからです。少なくとも、こちらの環境ではコピーも貼り付けも出来ていることを確認しています。

celsius710

2023/01/17 14:39

sk.exeさん質問に対する回答ありがとうございました。私の知識不足で教えていただいた内容で解決できず申し訳ありません。今回はpig_vbaさんの回答についてオートシェイプから赤字や取り消し線を抜き出すことはできなかったのですが、赤字か取り消し線が含まれているかの判定を行うことはでき、目的は達成できたため本スレについては問題解決とさせていただきます。ありがとうございました。

pig_vba

2023/01/18 00:27

＞少なくとも、こちらの環境ではコピーも貼り付けも出来ていることを確認しています。弊環境（Excel2019）ではその方法ではセルへの貼り付けは行われませんでした。(テキストボックスとして貼り付けられます)。環境の要因でしょうか？

行動規範の内容に同意します

ベストアンサー

ヒント程度の回答です

実際にそういう操作をしたことがないのでこういう方法で値を取得できると思いますよと提示にとどめます。

・オートシェイプから赤字を抜き出す。
・オートシェイプから取り消し線の文字列を抜き出す。

・ShapeRange(Z).TextFrame2.TextRange.Fontプロパティから入手できます。変数の場合は確かsheet.shapes.range(Z)でShapeRange(Z)が取得できたはずです。
With Activesheet.Shapes.Range(Z).TextFrame2.TextRange.Font
.Fill.ForeColor.RGB=RGB(255,0,0)'赤
.Strike=msoSingleStrike'一重取り消し線
end With

以下サイトはpowerpoint版ですが中身はexcelと同じでしょう。
TextRange.Font プロパティ (PowerPoint)

ShapeRangeオブジェクトの取得について
Shapes.Range プロパティ (Excel)

投稿2023/01/16 02:30

編集2023/01/16 06:30

pig_vba

総合スコア808