title: excel VBA: move overlapping shapes on worksheet
body: <p>I am creating a calendar where it pulls events from a user inputsheet and places a text box object on another worksheet (Dates across the top and different departments down the left).  It currently seperates the events on the top row of each section (i.e. all HR events on top row of HR section).  I then run a MACRO to check for overlapping objects and move them down to the next row.</p>
  
  <p>The code I use to move objects is below:</p>
  
  <pre><code>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 &lt;= 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 &lt;= (s1.Left + s1.Width) And s2.Left &gt;= s1.Left _
                  And s2.Top &lt;= (s1.Top + s1.Height) And s2.Top &gt;= 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
  </code></pre>
  
  <p>(I found this code in a different forum) This code works but is extremely slow.  It is comparing each textbox with all the text boxes on the worksheet.  My worksheet has over 3000 shapes and the MACRO takes over 4 hours to run.</p>
  
  <p>Is there a way to write this code to only move objects within certain ranges? (ie only HR section)</p>
  
  <p>Thanks</p>