Vba 在Excel中确定自选图形是否重叠/遮挡并垂直移动以解决

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

代码将查看用户输入来创建和分组shape&textbox，通常会创建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

Application.ScreenUpdate=False
将wb设置为工作簿
设置wb=ActiveWorkbook
将sh设置为工作表
设置sh=wb.ActiveSheet
将s1变暗为形状
将s2调整为形状将重叠调整为布尔值
对于i=1至10’sh.Shapes.Count
如果我尝试下面的代码。这将使活动工作表上的所有图表垂直对齐，相隔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

找到了答案：

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

Sub-MoveShapes1（）
Application.ScreenUpdating=False
将wb设置为工作簿
设置wb=ActiveWorkbook
将sh设置为工作表
设置sh=wb.ActiveSheet
将s1变暗为形状
将s2变暗为形状
Dim CheckOverlap作为布尔值
对于i=1到sh.Shapes.Count
如果我在最初插入形状时，为什么不指定它们的位置，使它们不会重叠？应该能够使用.Top和.Left属性.Hi DyRuss实现这一点-我对列执行.Left位置（以显示相关日期），并对目标受众执行.Top位置。该文档显示了6个月，并根据目标受众和日期绘制了通信事件。我们经常扩展或收缩视图以更详细地显示一个月或一周。创建和定位形状的数据经常会发生变化，因此无法指定单个形状相对于其他形状的放置位置-我需要在它们就位后垂直移动它们，如果需要，我会扩展特定单元格的行高度。我想我有一个解决方案。您希望图表在水平方向（如x轴上）或垂直方向（y轴上）相邻吗。所有的图表大小都差不多吗？所有的形状都有23分高和宽。我希望它们在垂直方向上相邻，也就是说，唯一的移动应该是向下移动，而不是水平移动。非常感谢。谢谢，但这并不是我想要的-我不想把它们平均地隔开作为一般规则，我只想在它们物理上重叠时才隔开。我已经编辑了上面的代码，以显示我目前正在尝试的内容。如果它有帮助，我可以给你一个例子，我希望它做什么，这样你可以得到一个更好的想法。谢谢你的帮助！