Excelワークシート上で重なり合った図形を移動する

Question

ユーザー入力シートからイベントをプルし、別のワークシート上にテキストボックスオブジェクトを配置するカレンダーを作成しています。現在、各セクションの一番上の行（つまり、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セクション）

おかげ

Answer 1

は、最初にすることはapplication.screenupdatingを使用することです。

また、いくつかの変数宣言が行われていないか、悪いことに実行されています（i、Sh）。

Gotoを使用しないでください。 （私はdo whileまたはdo untilループを使用するかもしれません）

明らかに、それぞれのループでテストするのはなぜですか？

あなたはそれぞれ（すでにも補正ウィッヒテスト形状）のために使用しないで If s2.ID = s1.ID Then GoTo Suitを避けることができ

が、for j=i+ 1 to sh.shapes.count : set S2=sh.shapes(j) .... `

少しリマインダー：長い上テストは、いくつかの条件で、VBAテストする場合は、すべての続行する前の条件ので、4つの条件をテストする代わりに、2つの重要なものだけをテストし、例えば、他の2つをテストしてください。then

注意、コメント、ボタンなどの多くのものもシェイプですので、シェイプタイプ（s1）のテストが必要な場合があります。 unessacerayループを避ける。

個人的には、辞書とクラスタイプを使用していますが、ループ全体に最大5秒かかってしまい、そのコードを書くことはできません。 あなたのアプローチはあなたのレベルにあります。ヒントを使ってコードの最適化を行うだけで十分です。