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

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

代码将看用户input来创build和分组形状和文本框，通常会创build超过100个形状，其中许多将重叠。 目前，这些组被放置在参考一行的顶部; 我想分开他们，以便他们不重叠。

我希望能够确定一个小组是否与另一个小组重叠，如果是，则将其移动下降25pts。 鉴于这个检查需要确定新的职位是否重叠，这对我的技能水平来说太复杂了（自学成才的初学者）。

我对此进行了广泛的研究，并且遇到了以下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 

我在这里find了代码的基础：

在Excel中命中testing并解决自选graphics的遮挡

但是，我还没有弄清楚如何检查重叠是垂直还是水平重叠，以及多重重叠的问题。 目前，如果我执行这个代码，它就会移动每一个形状，而不pipe它是否重叠。

如果有人能帮助我，我会很感激！ 这是我的项目中最难的部分，我很想find解决scheme。

非常感谢您的帮助

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

find答案：

 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