fc2ブログ

記事一覧

EXCEL(2010): 図形をセルの中央に移動するマクロ

このブログ、主に自転車の話題だけかと思うと、実はこんなネタも扱う。

会社の事務の人 「EXCELに貼り付けた画像をセルの中央に揃えることってできますか?」
私 「マクロ組めば簡単だけどね」
会社の事務の人 「それってやってもらえます?」

おいおい、人のことどんだけ暇人だと思ってるんだ?
面白そうなのでやってみた。

休日のささやかな頭の体操である。

Ver.1
Sub 選択したオブジェクトをセル範囲内の中央に移動()
'190420 ver.1
  Dim shp As Shape
  Dim rng0 As Range, rngV As Range, rngH As Range
  Dim myRow As Variant, myColumn As Variant
 
  If TypeName(Selection) = "Range" Then
  MsgBox "図形か画像を選択してください"
  Exit Sub
  End If
 
  For Each shp In Selection.ShapeRange
    myRow = shp.TopLeftCell.Rows.Row
    myColumn = shp.TopLeftCell.Columns.Column
    Set rng0 = Range(Cells(myRow, myColumn), Cells(myRow, myColumn))
    Set rngV = Range(Cells(myRow + 1, myColumn), Cells(myRow + 1, myColumn))
    Set rngH = Range(Cells(myRow, myColumn + 1), Cells(myRow, myColumn + 1))
  With shp
    .Top = (rngV.Top - rng0.Top - .Height) / 2 + rng0.Top
    .Left = (rngH.Left - rng0.Left - .Width) / 2 + rng0.Left
  End With
  Next
End Sub

xls01.png

ちなみに、新しい画像を貼り付ける際にセル中央にセンタリングするものなどは WEB で公開している人が居て、これらを参考にさせていただいたので、ソースコードに似ている個所がある。
そういう方々にお礼申し上げるとともに、もし不都合があればご指摘いただきたい。

さて、
これを組んでみて苦労したのが、レンジ(rng0)にCellで指定したRangeを代入するところで、以下のようなエラーが出ること。
image1.png
「実行時エラー '1004':」
「'Range' メソッドは失敗しました: '_Global' オブジェクト」

このエラーメッセージをググると、Cell とか Range の前に ActiveSheet. を付けろという対策しか見つからない。
やってみたけど直らねーよっ。
シート名入れたりBookまで指定したり、散々試したけどダメ。
諦めて昨日は寝て、今日いろんな人のソースを見ていたら、「Set」コマンド発見。

これで直った。
具体的には、
(誤)「rng0 = Range(Cells(myRow, myColumn), Cells(myRow, myColumn))」

(正)「Set rng0 = Range(Cells(myRow, myColumn), Cells(myRow, myColumn))」

ActiveSheet. 要らんやん!
逆に、Set 無しで上手く行っているのが不思議。
EXCELのバージョンとかが影響してるのかな?

ついでに、上記の対策調査中に見つけたソースをヒントに、もう一つ書いてみた。

Ver.2
Sub 選択したオブジェクトをセルの中央に移動()
'190420 ver.2
  Dim shp As Shape
 
  If TypeName(Selection) = "Range" Then
  MsgBox "図形か画像を選択してください"
  Exit Sub
  End If
 
  For Each shp In Selection.ShapeRange
  With shp
    .Top = (shp.TopLeftCell.Height - .Height) / 2 + shp.TopLeftCell.Top
    .Left = (shp.TopLeftCell.Width - .Width) / 2 + shp.TopLeftCell.Left
  End With
  Next
End Sub

こっちの方がはるかにシンプル。
Cell オブジェクトに .Top や .Left プロパティは使えないと思っていた。
使えるんやね。

Ver.1 でも Ver.2 でも、お好みに応じてご利用いただければと。

言うまでもないが、ご利用になる場合は自己責任でお願いします。




≪2019/4/22追記≫
できたマクロを意気揚々と、「やってみ」って会社の事務の人に渡したら、
会社の事務の人 「なんか、エラー13ってのがでましたー」
と。

私 「えっ?」

会社の事務の人の席に行って見せてもらうと、
err13.png
「実行時エラー '13':」
「型が一致しません。」

確かめてみると、会社の事務の人のPCに入っているのは Office2007 だった。
自宅でマクロ作ったのも、会社の私のPCも Office2010。
これはこれで古いんだが、まさかのバージョン問題。
MS って本当にどうしようもないなー。

会社の事務の人の隣のPC(Office2007)が空いていたので、お借りして奮闘すること30分。
不細工だが、このコードで無事走るようになった。
Sub 選択したオブジェクトをセルの中央に移動2007()
'190422 ver.3(Office2007対応)
 
  If TypeName(Selection) = "Range" Then
  MsgBox "図形か画像を選択してください"
  Exit Sub
  End If
 
  For iii = 1 To Selection.ShapeRange.Count
  With Selection.ShapeRange(iii)
    .Top = (Selection.ShapeRange(iii).TopLeftCell.Height - .Height) / 2 + Selection.ShapeRange(iii).TopLeftCell.Top
    .Left = (Selection.ShapeRange(iii).TopLeftCell.Width - .Width) / 2 + Selection.ShapeRange(iii).TopLeftCell.Left
  End With
  Next iii
End Sub

エラーが出ていたのは「For Each shp In Selection.ShapeRange」の個所。
「Selection.ShapeRange」を「shp」に代入するところがマズかった模様。

これを回避するために、Selection.ShapeRange を直接指定して実行させるようにした。
ちなみに、Office 2003 以前で動かなくてもしらん。

めでたしめでたし。



関連記事
スポンサーサイト



にほんブログ村 自転車ブログ 自転車生活へ ←このボタンをクリックすると書いている人のやる気が湧きます(それだけです)
にほんブログ村

コメント

コメントの投稿

非公開コメント

プロフィール

potaiko

Author:potaiko
関西在住のミニベロ=ちっちゃい自転車乗りです。
ポタリング/サイクリングの話題と自転車いじり(いわゆるカスタム)の話題が中心。
現在の愛車は5号車(こちら)、6号車(こちら)と7号車(こちら)の3台!

過去には、持ってるけど現在不稼働の1号車(こちら)、譲渡済みの2号車と3号車(こちら)、譲渡済みだがもうすぐ帰ってきそうな4号車(こちら)が存在している。

お約束: このブログは情報の正確さを保証するものではありません。参考にされる場合は、自己責任でお願いします。

フリーエリア

にほんブログ村 自転車ブログ 自転車生活へ にほんブログ村 写真ブログ 近畿風景写真へ にほんブログ村 地域生活(街) 関西ブログ 近畿情報へ PVアクセスランキング にほんブログ村