シート内図形のセルグリッド位置調整 Excel Macro

Excel方眼紙で図面を書いてるヤシに朗報だ。

複数の選択された図形オブジェクトを近傍点セルグリッドに合わせてくれるマクロだ。
・図形の左上基点グリッド合わせ（サイズ変更なし）
・図形の右下基点グリッド合わせ（サイズ変更なし）
・図形の左右上下すべてのグリッド合わせ（サイズ変更）

上記３つのどれかを選んで位置調整。

調整方向は縦／横／縦横が選べる。コネクタの除外指定もアリ。

ただし、コネクタはExcelのバージョンによって挙動が違うので期待するな。

Macroのつぼ

VBAのウィンドでフォームの追加をしろし。
フォーム名は"AdjustObject"
フォーム内に何のコントロールを貼るかは、上の画面とフォームのInitialロジックを見て
考えてくれ。フォームをロードするエントリ関数は”図位置調整()”。これを呼び出せば動く。

化石言語BASIC固有の文法で、EndiFを書かないIf文や行番号ジャンプが書かれている。
また、"If CONTROL Then ･･･"は、"If CONTROL.value = True Then･･･"と同じだ。
両方ともコードをシンプルにする為に、ベストな方法だ。
goto文は必要な箇所に充分つかえし。

AdjustObject（コード）

Private Sub UserForm_Initialize() CheckTopLeft = True CheckBottomRight = True OptionX = False OptionY = False OptionYX = True End Sub Private Sub CommandExec_Click() Dim YX As Integer Dim nMode As Integer Dim bAboidConnect As Boolean If OptionX Then YX = 2 If OptionY Then YX = 1 If OptionYX Then YX = 3 nMode = 0 If CheckTopLeft Then nMode = 1 If CheckBottomRight Then nMode = nMode + 2 If CheckConnect Then bAboidConnect = True Else bAboidConnect = False End If Call AdjustOBJ(YX, nMode, bAboidConnect) End Sub

標準モジュール
Sub 図位置調整() AdjustObject.Show End Sub Sub AdjustOBJ(YX As Integer, nMode As Integer, bAboidConnect As Boolean) Dim p1, p2 As Object Dim yy, xx As Double If nMode = 0 Then Exit Sub If TypeName(Selection) = "Range" Then Exit Sub For i = 1 To Selection.ShapeRange.Count With Selection.ShapeRange(i) If InStr(.Name, "Comment") > 0 Then GoTo 100 If InStr(.Name, "onnect") > 0 And bAboidConnect Then GoTo 100 Set p1 = GetNearCell(.Top, .Left, .TopLeftCell) Set p2 = GetNearCell(.Top + .Height, .Left + .Width, .BottomRightCell) If nMode = 1 Then If YX = 1 Or YX = 3 Then .Top = p1.Top If YX = 2 Or YX = 3 Then .Left = p1.Left ElseIf nMode = 2 Then If YX = 1 Or YX = 3 Then .Top = p2.Top - .Height If YX = 2 Or YX = 3 Then .Left = p2.Left - .Width Else If YX = 1 Or YX = 3 Then .Top = p1.Top: .Height = p2.Top - p1.Top If YX = 2 Or YX = 3 Then .Left = p1.Left: .Width = p2.Left - p1.Left End If 100 End With Next End Sub Function GetNearCell(y As Double, x As Double, ByRef tg As Object) As Object Set p = ActiveSheet.Cells(tg.Row + 1, tg.Column + 1) If (y - tg.Top) > (p.Top - y) Then If (x - tg.Left) > (p.Left - x) Then Set GetNearCell = p Else Set GetNearCell = ActiveSheet.Cells(p.Row, tg.Column) End If Else If (x - tg.Left) > (p.Left - x) Then Set GetNearCell = ActiveSheet.Cells(tg.Row, p.Column) Else Set GetNearCell = tg End If End If End Function