Help us understand the problem. What is going on with this article?

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

More than 5 years have passed since last update.

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

概要

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

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

使い方

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

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

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

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

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

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

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

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

  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
shibainurou
Qiita:Team使いたい
Why not register and get more from Qiita?
  1. We will deliver articles that match you
    By following users and tags, you can catch up information on technical fields that you are interested in as a whole
  2. you can read useful information later efficiently
    By "stocking" the articles you like, you can search right away