确定Excel中的自选图形是否重叠/遮挡，并垂直移动以进行解析

Question

我正在使用一些VBA代码创建一个自动形状和一个文本框，将它们分组，并根据单元格位置移动到垂直和水平位置。

该代码将查看用户输入以创建和分组形状&文本框，通常会创建100多个形状，其中许多形状会重叠。目前，这些组是参照一行的顶部放置的；我想把它们分开，这样它们就不会重叠。

我希望能够确定一个组是否与另一个组重叠，如果是，则将其向下移动25分。考虑到这项检查需要确定新职位是否也重叠，这对我的技能水平（自学成才的初学者）来说有点太复杂了

我对此进行了广泛的研究，并发现了以下VBA代码：

Application.ScreenUpdating = False
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim sh As Worksheet
Set sh = wb.ActiveSheet
Dim s1 As Shape
Dim s2 As Shape     Dim CheckOverlap As Boolean
For i = 1 To 10 'sh.Shapes.Count
If i <= sh.Shapes.Count Then
        Set s1 = sh.Shapes(i)
        CheckOverlap = False
        For Each s2 In Worksheets("Plan").Shapes
                    If s2.Left < (s1.Left + s1.Width) And s2.Top < (s1.Top + s1.Height) Then
                        CheckOverlap = True
                        Exit For
                    End If
        Next
    If CheckOverlap = True Then
        s2.Top = s2.Top + 30
        End If
End If
Next
End Sub

我在这里找到了代码的基础：

Excel 中AutoShapes的命中测试与遮挡解决

然而，我还没能弄清楚如何让它检查垂直和水平是否发生重叠，以及多重重叠问题。目前，如果我执行该代码，它只会向下移动每个形状，即使它是否重叠。

如果有人能帮我，我会非常感激的！这是我项目中最困难的部分，我很想找到一个解决方案。

非常感谢您的帮助

Answer 1

尝试以下代码。这应该将活动表上的所有图表垂直对齐，相隔25点

Sub MoveShapes()
   Dim IncrementTop, TopPosition, LeftPosition, i as Long
   IncrementTop = 0
   LeftPosition = 'place the desired starting left position here
   TopPosition = 'place the desired starting top position here
   For i = 1 To ActiveSheet.Shapes.Count
      ActiveSheet.Shapes(i).Left = LeftPosition
      ActiveSheet.Shapes(i).Top = TopPosition + IncrementTop
      IncrementTop = IncrementTop + 25
   Next i
End Sub

Answer 2

找到答案：

Sub MoveShapes1()
Application.ScreenUpdating = False
Dim wb As Workbook
Set wb = ActiveWorkbook
Dim sh As Worksheet
Set sh = wb.ActiveSheet
Dim s1 As Shape
Dim s2 As Shape
Dim CheckOverlap As Boolean
For i = 1 To sh.Shapes.Count
If i <= sh.Shapes.Count Then
        Set s1 = sh.Shapes(i)
Search:
    CheckOverlap = False
    For Each s2 In Worksheets("Plan").Shapes
        If s2.ID = s1.ID Then GoTo Suit
        If s2.Left <= (s1.Left + s1.Width) And s2.Left >= s1.Left _
        And s2.Top <= (s1.Top + s1.Height) And s2.Top >= s1.Top Then
            s1.Top = s1.Top + 32
            CheckOverlap = True
            Exit For
        End If
Suit:
        Next
    If CheckOverlap = True Then GoTo Search
    End If
Next
Application.ScreenUpdating = True
End Sub