【ExcelVBA】図形をセル中央に整列させる

図形移動の処理を作れたのですが、
Dragで移動させられると楽なのにと思っています。

そこで、Drop時にセルの中央に合わせられないかと考えていたのですが、
実現が難しいんですよね。(￣~￣；) ウーン

いろいろと考えて思いついたのが、
図形を一括で整列させる方法です。

Drop時にセル中央に移動しなくても
移動させた図形を一括でセル中央に整列させられれば、
もう少し、直感的な作業ができるのでは！？と考えました。

これなら図形を個々に調整するより楽かもって事で処理を考えてみます。

まず図形がどのセル上にあるか判断する必要があります。
セルが分かれば、そのセルの中央に移動させるだけの処理なので簡単に作れそうです。

シート上の図形を取得して、どのセルか割り出します。
標準モジュール

Option Explicit

Sub CellSearch()

    Dim sh As Shape     'シート上の図形取得'
    Dim cell As Range   '図形下のセルを取得'
    
    For Each sh In ActiveSheet.Shapes

        With ActiveSheet.Shapes(sh.Name)
            Set cell = Range(.TopLeftCell, .BottomRightCell)

        End With
        
    Next
    
    MsgBox cell.Address
    
End Sub

シート上の図形を探して、どのセル上にあるか調べさせます。
前回記事でも書きましたが、TopLeftCellとBottomRightCellを使って調べます。

図形の左上と右下の角が乗ってるセルを特定する事ができます。

ちなみに、シート上に置くボタンもシェイプ扱いになるので、
操作ボタンは、ユーザーフォームに設定しておく方が無難です。

セルが取得できるかテストしてみます。
図形揃え①.jpg
問題無く取得できてます。

後は、セルの中央に移動するようにさせるだけです。
標準モジュール

Sub ShapeAlignment()

    Dim sh As Shape     'シート上の図形取得'
    Dim cell As Range   '図形下のセルを取得'
    
    For Each sh In ActiveSheet.Shapes

        With ActiveSheet.Shapes(sh.Name)
            Set cell = Range(.TopLeftCell, .BottomRightCell)

            .Top = cell.Top + (cell.Height - .Height) / 2
            .Left = cell.Left + (cell.Width - .Width) / 2

        End With
        
    Next
    
End Sub

図形を見つけたらセル位置を割出して、
そのセルの中央に移動させるだけになります。

For Each sh In ActiveSheet.Shapes～Nextで、シート上の全ての図形を取得できるので、
全図形に中央揃えが適用されます。

これで問題無く中央揃えができると思うので、テストしてみます。
図形揃え②.jpg
こんな感じで配置して、揃えボタンをPush。

なんか無茶苦茶にならんでます。( ゜.゜) ポカーン
図形揃え③.jpg
TopLeftCellとBottomRightCellは、図形の左上と右下が乗ってるセルを調べるものなので、
当然、セル跨ぎをすると二つのセルが取得される事になります。
なので、均等揃えをすると二つセルの中央に移動してしまいます。(T-T) グスッ

これでは、セルからハミ出るとセル境界を中心に揃ってしまいます。

ある程度セルからハミ出しても、狙いのセルに移動してくれないと
使いにくい感じになるので、修正案を考えてみます。

・一番多く図形が乗ってるセルを探す。
・起点になるセルを作って、図形の位置境界を割出す。

要素としては、この二つくらいでしょうか。

セルに乗ってる面積が割出せれば、比較するのは簡単なんで調べてみました。
けれど、面積を取得する方法を見つける事ができませんでした～　(ノ_<。)うっうっうっ

しかたがないので、二番目の図形位置境界を割出す方法を考えてみます。
図形揃え⑤.jpg
図形を二つのセルの中央に配置した時、セルの幅から図形の半分が重なる事になります。
なので、緑線以内なら左のセル、それより大きいなら右のセルと判断できます。

同じように、縦の境界も作って、上下で判断させるようにしてみます。

計算式としては、

    左セルの幅－（図形の幅／2）＝境界の幅
    左セルの高さ－（図形の高さ／2）＝境界の高さ

こんな感じになるかと思います。
この境界をIF文で判断させれば上手く機能しそうです。

境界内なら中央に移動させればいいのですが、
境界を超えた場合は、どうしようか？って事なんですが…

左セルの中央に移動させた図形に、セルの幅を足してやれば、
右のセル中央になるので、補正するだけですみそうです。

縦の計算も考えてコードを組んでみます。
標準モジュール

Option Explicit

Sub PositionCheck()

    Dim sh As Shape    '図形取得'
    Dim cell As Range  '図形下セル取得'
    
    Dim posLeft As Double    '図形の左位置'
    Dim posTop As Double     '図形の縦位置'
    Dim leftBorder As Double '横境界線'
    Dim topBorder As Double  '縦境界線'
    
    Dim addLeft As Integer   '横の補正値'
    Dim addTop As Integer    '縦の補正値'
    
    
    For Each sh In ActiveSheet.Shapes
    
        Set cell = ActiveSheet.Shapes(sh.Name).TopLeftCell
        addLeft = 0
        addTop = 0
            
        '境界線を計算'
        leftBorder = cell.Width - (sh.Width / 2)
        topBorder = cell.Height - (sh.Height / 2)
    
        '図形の位置を計算'
        posLeft = sh.Left - cell.Left
        posTop = sh.Top - cell.Top
    
        '境界を越えてるか判断'
        If posLeft > leftBorder Then
            addLeft = cell.Width
            
        End If
        
        If posTop > topBorder Then
            addTop = cell.Height
            
        End If
        
        '図形の移動'
        With ActiveSheet.Shapes(sh.Name)
            .Top = cell.Top + (cell.Height - .Height) / 2 + addTop
            .Left = cell.Left + (cell.Width - .Width) / 2 + addLeft

        End With
    
    Next
    
End Sub

まず、図形の乗ってるセルは左側が分かれば計算できるので、
TopLeftCellだけで取得します。

後は境界を超えたか超えてないか判断して、
起点のセルに中央揃えした後、addLeft とaddTopで補正してやれば、
狙ったセルに移動してくれると思います。

早速テストしてみます。
図形揃え⑥.jpg

恐る恐るボタンを押すと…
図形揃え⑦.jpg
上手く移動してくれました。（*＾_＾*）v ヤッタネ

これでDragで図形移動させて、ボタン一発で中央揃えが可能になったので、
より直感的な移動作業ができるようになりました。

しかし、既に中央に揃ってる図形を何度も移動処理させるってのも無駄なんで、
選択した図形だけ整列する処理も作ってみます。
標準モジュール

Option Explicit

Sub SelectedShape()

    Dim sh As Shape    '図形取得'
    Dim cell As Range  '図形下セル取得'
    
    Dim posLeft As Double    '図形の左位置'
    Dim posTop As Double     '図形の縦位置'
    Dim leftBorder As Double '横境界線'
    Dim topBorder As Double  '縦境界線'
    
    Dim addLeft As Integer   '横の補正値'
    Dim addTop As Integer    '縦の補正値'
    
    
    On Error GoTo Unselected
    
    For Each sh In Selection.ShapeRange
    
        Set cell = ActiveSheet.Shapes(sh.Name).TopLeftCell
        addLeft = 0
        addTop = 0
            
        '境界線を計算'
        leftBorder = cell.Width - (sh.Width / 2)
        topBorder = cell.Height - (sh.Height / 2)
    
        '図形の位置を計算'
        posLeft = sh.Left - cell.Left
        posTop = sh.Top - cell.Top
    
        '境界を越えてるか判断'
        If posLeft > leftBorder Then
            addLeft = cell.Width
            
        End If
        
        If posTop > topBorder Then
            addTop = cell.Height
            
        End If
        
        '図形の移動'
        With ActiveSheet.Shapes(sh.Name)
            .Top = cell.Top + (cell.Height - .Height) / 2 + addTop
            .Left = cell.Left + (cell.Width - .Width) / 2 + addLeft

        End With
    
    Next
    
    Exit Sub
    
Unselected:
MsgBox "選択されてないよ！"

End Sub

ループの条件をSelection.ShapeRangeに変更すれば、
選択した図形のみになります。

図形が未選択の場合は、エラーが発生するので、
エラー時の処理を入れておくといいです。

これで少しは、直感的な作業ができるようになったのかは疑問ですが、
図形を選択してセル移動よりは、楽に図形移動ができるようになったと思います。

図形移動に関しては、以上となります。

図形作成まで作れたので、次はラインで繋ぐ工程を作っていこうと思います。
それでは、(o・・o)/~マタネェ

この記事へのコメント

コメントを書く