VBA100本ノック 19本目：図形のコピー

最終更新日：2021-06-26

VBA100本ノック 19本目：図形のコピー

シートの全図形をコピーする問題です。
繰り返し実行しても図形が増殖しないようにします。

ツイッター連動企画です。
ツイートでの見やすさを考慮して、ブック・シート指定等を適宜省略しています。

VBAテスト用のサンプルデータは、VBA100本ノックの目次ページ からもダウンロードできます。

マクロVBAを初心者向けの基本から上級者向けの高度な内容までサンプルコードを掲載し解説しています。エクセル関数・機能・基本操作の入門解説からマクロVBAまでエクセル全般を網羅しています。

出題

#VBA100本ノック 19本目
引数でWorksheetを受け取り以下の処理を行うSubを作成してください。
シートの全図形について画像のように元図形の真横にくっ付けてコピー。
繰り返し実行しても増殖しないように工夫する。
※何らかの規則・制限を設けて構いません。
※入力規則のリストに気を付けて。

サンプルファイルです。
https://excel-ubara.com/vba100sample/VBA100_19.xlsm
https://excel-ubara.com/vba100sample/VBA100_19.zip

VBA作成タイム

この下に頂いた回答へのリンクと解説を掲載しています。
途中まででも良いので、できるだけ自分でVBAを書いてみましょう。

他の人の回答および解説を見て、書いたVBAを見直してみましょう。

頂いた回答

出題ツイートの引用ツイートでの回答

解説

シートの全図形はShapes(Shapeのコレクション)に入っています。
Shapesには入力規則のドロップダウンも含まれているので対象外にする必要があります。
ShapeをコピーするメソッドはCopyですが、同一シート内の場合はDuplicateが便利です。
複製した図形には特別な名前を付けて判別しています。


  
    
      Sub VBA100_19_01(ByVal ws As Worksheet)

      　　Dim sp As Shape

　　

　　For Each sp In ws.Shapes

　　　　If sp.Name Like "*【VBA100_19】*" Then

　　　　　　sp.Delete

　　　　End If

　　Next

　　

　　For Each sp In ws.Shapes

　　　　If sp.Type <> msoFormControl And sp.Type <> msoOLEControlObject Then

　　　　　　With sp.Duplicate

　　　　　　　　.Name = sp.Name & "【VBA100_19】"

　　　　　　　　.Top = sp.Top

　　　　　　　　.Left = sp.Left + sp.Width

　　　　　　End With

　　　　End If

　　Next

End Sub

Duplicateはオブジェクトを返してくれるので便利ですね。
増殖を抑える方法として、Nameの代わりにAlternativeTextを使うような方法も考えられそうです。
AlternativeTextとCopyメソッドを使った場合のVBAサンプルは記事補足に掲載しました。

補足

コピーの増殖を抑える方法について

元の図とコピーした図を判別する為には何らかの規則・制限が必要になります。
いろいろな方法が考えられますが、
・規則・制限による不便さ
・実装の容易さ
これらを天秤にかけることになります。
規則は確実に守られるならどんな規則でも良いのですが、出来れば規則を知らなくても自然と守られるような規則が望ましいですね。
名前に通常使わないような特別な文字列を使う方法は簡易かつかなり確実に守られると思います。
最大の欠点は、これによりコピーされた図を、さらに手動でコピーした時になると思います。
名前もそのままコピーされてしまうので、これは判別できなくなります。

CopyメソッドとDuplicateメソッド

ShapeのCopyメソッドは戻り値がなく、コピーされた図形が選択状態になります。
対して、Duplicateメソッドは複製してオブジェクトが返されます。
したがって、Duplicateを使うと図形を複製した後のオブジェクトが簡単に指定できるところが便利です。

入力規則のドロップダウンについて

入力規則のドロップダウンは、シートを開いて一度も使っていないとShapesに入っていないのですが、
セルを選択して、▽を表示した時点でShapesに入ってきます。
そもそもフォームコントロールを共通に扱うのは難しいので、これを除外しました。
ActiveXコントロールも併せて除外しています。

ShapeのType

MsoShapeType列挙	値	説明
msoAutoShape	1	オートシェイプ
msoCallout	2	引き出し線
msoCanvas	20	キャンバス
msoChart	3	グラフ
msoComment	4	コメント
msoDiagram	21	ダイアグラム
msoEmbeddedOLEObject	7	埋め込み OLE オブジェクト
msoFormControl	8	フォームコントロール
msoFreeform	5	フリーフォーム
msoGroup	6	グループ
msoIgxGraphic	24	SmartArt グラフィック
msoInk	22	インク
msoInkComment	23	インクコメント
msoLine	9	直線
msoLinkedOLEObject	10	リンク OLE オブジェクト
msoLinkedPicture	11	リンク画像
msoMedia	16	メディア
msoOLEControlObject	12	OLE コントロールオブジェクト
msoPicture	13	画像
msoPlaceholder	14	プレースホルダー
msoScriptAnchor	18	スクリプトアンカー
msoShapeTypeMixed	-2	図形の種類の組み合わせ
msoTable	19	テーブル
msoTextBox	17	テキストボックス
msoTextEffect	15	テキスト効果

CopyメソッドとAlternativeTextを使ったサンプル


  
    
      Sub VBA100_19_02(ByVal ws As Worksheet)

      　　Dim sp As Shape

      　　

      　　For Each sp In ws.Shapes

      　　　　If sp.AlternativeText Like "*【VBA100_19】*" Then

      　　　　　　sp.Delete

      　　　　End If

      　　Next

      　　

      　　For Each sp In ws.Shapes

      　　　　If sp.Type <> msoFormControl And sp.Type <> msoOLEControlObject Then

      　　　　　　sp.Copy

      　　　　　　Application.Wait Now() + TimeSerial(0, 0, 1)

      　　　　　　ws.Paste

      　　　　　　Application.Wait Now() + TimeSerial(0, 0, 1)

      　　　　　　With ws.Shapes(ws.Shapes.Count)

      　　　　　　　　.AlternativeText = sp.AlternativeText & vbCrLf & "【VBA100_19】"

      　　　　　　　　.Top = sp.Top

      　　　　　　　　.Left = sp.Left + sp.Width

      　　　　　　End With

      　　　　End If

      　　Next

      　　

      　　ws.Protect

      　　ws.Unprotect

      End Sub

複製した図形の判定にAlternativeTextを使用しています。
Copyメソッドを使用しているので、コピー後のオブジェクトを特定するためにコピーされた図形はコレクションの最後に入ることを利用しています。
これは、Selectionを使ってもよいでしょう。

ただし上記VBAのとおり、CopyおよびPasteでは、一定時間の待ちを設ける必要があります。
待ちを入れなくても上手く動作する場合もありますが、かなりの確率でエラーになってしまいます。
Shapeの数が多い場合は処理時間がとてもかかってしまいます。

VBA終了時に図形が選択された状態を解除するのに、シートをSelectせずに行う方法としてProtectを利用しています。

サイト内関連ページ

第97回．図形オートシェイプ（Shape）

・図形オートシェイプ（Shape）関連のオブジェクト群・図形オートシェイプ（Shape）の追加・図形オートシェイプ（Shape）の削除・図形オートシェイプ（Shape）の編集・図形オートシェイプ（Shape）の全選択・図形オートシェイプ（Shape）の扱い方を工夫する・オートシェイプ（Shape）を扱う実践例・図形オートシェイプ（Shape）に関連する記事

オートシェイプを他ブックの同じ位置に貼り付ける（Shapes,DrawingObjects）

コメントでリクエストを頂きました。「１つのシートにバラバラにあるオートシェープを一度に選択して、コピーし、ほかのブックのあるシートの同じ位置にペーストしたい」というもの。これには色々な問題が含まれています。

図形オートシェイプ（Shape）の複数選択

・ワークシートの全てのShapeを選択する場合・ShapeオブジェクトのSelectメソッド・ShapeRangeオブジェクト・シート内の指定名称の図形を選択

図形（Shape）関連のプロパティ、メソッド一覧

・Shapesコレクション・・・ Shapeオブジェクトのコレクション・Shapeオブジェクト・・・オートシェイプやピクチャなど、描画レイヤーのオブジェクト・ShapeRangeオブジェクト・・・文書の図形セットである図形範囲を表します。・GroupShapesオブジェクト・・・グループ化した図形を表します。・FillFormatオブジェクト・・・図形の塗りつぶしの書式設定を表します。・LineFormatオブジェクト・・・線と矢印の両端の書式を表します。・TextFrameオブジェクト・・・レイアウト枠を表します。・TextFrame2オブジェクト・・・ 2007から追加されたTextFrameの後継オブジェクト。

同じテーマ「VBA100本ノック」の記事

16本目：無駄な改行を削除
 17本目：重複削除（ユニーク化）
18本目：名前定義の削除
19本目：図形のコピー
20本目：ブックのバックアップ
 21本目：バックアップファイルの削除
 22本目：FizzBuzz発展問題
 23本目：シート構成の一致確認
 24本目：全角英数のみ半角
 25本目：マトリックス表をDB形式に変換
 26本目：ファイル一覧作成

アクセスランキング・・・ランキング一覧を見る

1.最終行の取得（End,Rows.Count）｜VBA入門
2.RangeとCellsの使い方｜VBA入門
3.繰り返し処理（For Next)｜VBA入門
4.変数宣言のDimとデータ型｜VBA入門
5.セルのコピー&値の貼り付け（PasteSpecial）｜VBA入門
6.マクロとは？VBAとは？VBAでできること｜VBA入門
7.ブックを閉じる・保存（Close,Save,SaveAs）｜VBA入門
8.並べ替え（Sort）｜VBA入門
9.Range以外の指定方法（Cells,Rows,Columns）｜VBA入門
10.条件分岐（IF）｜VBA入門

ホーム
マクロVBA入門編
VBA100本ノック
19本目：図形のコピー

このサイトがお役に立ちましたら「シェア」「Bookmark」をお願いいたします。

記述には細心の注意をしたつもりですが、
間違いやご指摘がありましたら、「お問い合わせ」からお知らせいただけると幸いです。
掲載のVBAコードは動作を保証するものではなく、あくまでVBA学習のサンプルとして掲載しています。
掲載のVBAコードは自己責任でご使用ください。万一データ破損等の損害が発生しても責任は負いません。

VBA練習問題
VBA100本ノック 19本目：図形のコピー