我正在创建一个日历,用于从用户输入表中提取事件,并将文本框对象放在另一个工作表上(左上方的日期和左下方的不同部门)。它目前在每个部分的顶行分离事件(即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部分)
由于
答案 0 :(得分:0)
首先要使用application.screenupdating
。
一些变量声明也没有或者做得不好(i,Sh)。
不要使用Goto
。 (我可以使用do while
或do 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循环,并且我不会为你编写代码。 你的方法更符合你的水平,并且使用我给出的提示进行了一些代码优化就足够了。