excel VBA:在工作表上移动重叠的形状

时间:2016-12-14 21:57:57

标签: excel-vba object textbox vba excel

我正在创建一个日历,用于从用户输入表中提取事件,并将文本框对象放在另一个工作表上(左上方的日期和左下方的不同部门)。它目前在每个部分的顶行分离事件(即HR部分顶行的所有HR事件)。然后我运行MACRO来检查重叠的对象并将它们移动到下一行。

我用来移动对象的代码如下:

Sub MoveShapes()

'This Macro moves overlapping shapes down to the next row

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

Worksheets("SRTC").Activate

    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("SRTC").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 + 18 ' 32
                CheckOverlap = True
            Exit For
            End If
Suit:
            Next
        If CheckOverlap = True Then GoTo Search
        End If
    Next

End Sub

(我在不同的论坛中发现了这段代码)这段代码有效,但速度极慢。它将每个文本框与工作表上的所有文本框进行比较。我的工作表有超过3000个形状,MACRO需要4个多小时才能运行。

有没有办法编写此代码只能移动特定范围内的对象? (即只有HR部分)

由于

1 个答案:

答案 0 :(得分:0)

首先要使用application.screenupdating

一些变量声明也没有或者做得不好(i,Sh)。

不要使用Goto。 (我可以使用do whiledo until循环)

为什么要对每个循环If i <= sh.Shapes.count Then进行测试,显然情况如此?

你可以避免If s2.ID = s1.ID Then GoTo Suit不为每个使用a(也测试已经修正的形状),但是for j=i+ 1 to sh.shapes.count : set S2=sh.shapes(j) ....`

小提醒:在长IF测试中,有几个条件,VBA将在继续之前测试所有条件,因此不测试4个条件,只测试2个更重要的,then测试另外两个,例如

当心,评论,按钮和许多其他东西也是一种形状,所以你可能需要测试形状的类型(在s1上)。避免使用循环。

就个人而言,我使用字典和类类型,整个过程最多需要5个secondes循环,并且我不会为你编写代码。 你的方法更符合你的水平,并且使用我给出的提示进行了一些代码优化就足够了。