Question

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

代码将查看用户输入以创建和分组形状＆amp;文本框，通常会创建超过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

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

Hit-Testing and Resolving Occlusion of AutoShapes in Excel

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

如果有人可以帮助我，我会非常感激！这是我项目中最难的部分，我很乐意找到解决方案。

非常感谢你的帮助

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

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

2 个答案: