オートシェイプとオートシェイプの間の隙間を消す

Excelのオートシェイプで画面レイアウトなどを作らされ、背中が煤けてしまった人々に捧ぐ

概要

選択したオートシェイプ間の隙間を消して、オートシェイプ同士をくっつけます。

SelectionShapesMagnetHorizon は、一番左のオートシェイプを起点に、左右の隙間を
SelectionShapesMagnetVerticalは、一番上のオートシェイプを起点に、上下の隙間を消す。

使い方

1. デスクトップに適当な新規エクセルファイルを作ります。

2. 適当なエクセルを開きます。

3. alt+F11を押してVisualBasicEditorを開きます。

4. 適当に開いたエクセルにModuleを追加します。

5. Moduleに下のソースをコピペします。

6. 適当に開いたエクセルを保存します。

7. くっつけたいオートシェイプがあるエクセルの、くっつけたいオートシェイプを選択状態にします。

8. alt+F8を押して。実行マクロ(SelectionShapesMagnetHorizon orSelectionShapesMagnetVertical )を選択します。

9. 煤けて真っ黒になってしまった背中の色がちょっと薄くなります。

注意！

マクロを使用すると過去の編集履歴がクリアされます。
一旦保存してから使いましょう。

Public Type StShapesInfoH
	index As Integer
	left As Double
	width As Double
End Type

Public Type StShapesInfoV
	index As Integer
	top As Double
	height As Double
End Type

'選択されているオートシェイプをくっつける(横)
Sub SelectionShapesMagnetHorizon()
   
    Dim ShapesInfo() As StShapesInfoH
    ReDim ShapesInfo(Selection.ShapeRange.count - 1)
    
    Dim t As Integer
    Dim i As Integer
    For i = 0 To Selection.ShapeRange.count - 1
        ShapesInfo(i).index = i + 1  ' 一意になるデータが無いのでindexを使う
        ShapesInfo(i).left = Selection.ShapeRange(i + 1).left
        ShapesInfo(i).width = Selection.ShapeRange(i + 1).width
    Next
    
    
    '最大取得
    Dim work As StShapesInfoH
    Dim max As StShapesInfoH
    Dim index As Integer
    
    For i = 0 To Selection.ShapeRange.count - 1
        max.index = -1
        max.left = 0
        max.width = 0
        index = 0

        For t = i To Selection.ShapeRange.count - 1
            ' 同じ位置にあるシェイプのindexが-1になっちゃうので同じだったら、後ろのほうが大きい
            If max.left <= ShapesInfo(t).left Then
                max = ShapesInfo(t)
                index = t
            End If
        Next
        work = ShapesInfo(i)
        ShapesInfo(i) = max
        ShapesInfo(index) = work
    Next
    
    Dim j As Integer
    For i = Selection.ShapeRange.count - 1 To 1 Step -1
        ShapesInfo(i - 1).left = ShapesInfo(i).left + ShapesInfo(i).width
    Next
    
    For i = 0 To Selection.ShapeRange.count - 1
        Selection.ShapeRange(ShapesInfo(i).index).left = ShapesInfo(i).left
    Next
    
End Sub


'選択されているオートシェイプをくっつける(縦)
Sub SelectionShapesMagnetVertical()
   
    Dim ShapesInfo() As StShapesInfoV
    ReDim ShapesInfo(Selection.ShapeRange.count - 1)
    
    Dim t As Integer
    Dim i As Integer
    For i = 0 To Selection.ShapeRange.count - 1
        ShapesInfo(i).index = i + 1 ' 一意になるデータが無いのでindexを使う
        ShapesInfo(i).top = Selection.ShapeRange(i + 1).top
        ShapesInfo(i).height = Selection.ShapeRange(i + 1).height
    Next
    
    
    '最大取得
    Dim work As StShapesInfoV
    Dim max As StShapesInfoV
    Dim index As Integer
    
    For i = 0 To Selection.ShapeRange.count - 1
        max.index = -1
        max.top = 0
        max.height = 0
        index = 0

        For t = i To Selection.ShapeRange.count - 1
            ' 同じ位置にあるシェイプのindexが-1になっちゃうので同じだったら、後ろのほうが大きい
            If max.top <= ShapesInfo(t).top Then
                max = ShapesInfo(t)
                index = t
            End If
        Next
        work = ShapesInfo(i)
        ShapesInfo(i) = max
        ShapesInfo(index) = work
    Next
    
    Dim j As Integer
    For i = Selection.ShapeRange.count - 1 To 1 Step -1
        ShapesInfo(i - 1).top = ShapesInfo(i).top + ShapesInfo(i).height
    Next
    
    For i = 0 To Selection.ShapeRange.count - 1
        Selection.ShapeRange(ShapesInfo(i).index).top = ShapesInfo(i).top
    Next
End Sub