Excel 2003, wie oben links und unten rechts im Bereich zu bekommen?

Question

Ich habe einen Bereich, den ich überprüfen möchte, ob irgendwelche Formen darauf platziert sind.

fand ich ein Skript online (http://www.mrexcel.com/forum/excel-questions/317711-visual-basic-applications-identify-top-left-cell-selected-range.html), aber es funktioniert nicht für Excel 2003. Der Code habe ich so weit, die aus dem gefundenen Skript adapated ist:

Public Function removeOLEtypesOfType() As Boolean 
     On Error Resume Next 

     Dim objTopLeft As Range, objBotRight As Range _ 
      , objRange As Range, objShape As Shape 
     Set objRange = Sheet1.Range(COLUMN_HEADINGS) 
     objRange.Select 

     With Selection 
      Dim intFirstCol As Integer, intFirstRow As Integer _ 
       , intLastCol As Integer, intLastRow As Integer 
      intFirstCol = .Column 
      intFirstRow = .Row 
      Set objTopLeft = .Cells(intFirstRow, intFirstCol) '.Address(0, 0) 
      intLastCol = .Columns.Count + .Column - 1 
      intLastRow = .Rows.Count + .Row - 1 
      Set objBotRight = .Cells(intLastRow, intLastCol) '.Address(0, 0) 

      If objTopLeft Is Nothing Or objBotRight Is Nothing Then 
       MsgBox "Cannot get topleft or bottom right of range!", vbExclamation 
       removeOLEtypesOfType = False 
       Exit Function 
      End If 
      For Each objShape In ActiveSheet.Shapes 
       Dim objTLis As Range 
       Set objTLis = Intersect(objTopLeft, objShape.TopLeftCell) 

       If Not objTLis Is Nothing Then 
        Dim objBRis As Range 
        Set objBRis = Intersect(objBotRight, objShape.BottomRightCell) 

        If Not objBRis Is Nothing Then 
         objShape.Delete 
        End If 
       End If 
      Next 
     End With 
     Sheet1.Cells(1, 1).Select 
     removeOLEtypesOfType = True 
    End Function 

objTopLeft und objBotRight sind beide Nichts , COLUMN_HEADINGS enthält den Namen des Bereichs.

Ich habe intFirstCol, intFirstRow, intLastCol und intLastRow im Debugger überprüft und sie sind korrekt.

Edit ... Mit .Adresse auskommentiert sowohl beide topleft und botright Bereiche zurückgegeben werden aber mit .Address in, beide sind nichts. Die zurückgegebenen Bereiche scheinen nicht für die richtigen Standorte zu sein.

Zum Beispiel für den Bereich geliefert:

intFirstCol = 3 
    intFirstRow = 11 
    intLastCol = 3 
    intLastRow = 186 

Die oben korrekt sind, aber:

objTopLeft.Column = 5 
    objTopLeft.Row = 21 
    objBotRight.Column = 5 
    objBotRight.Row = 196 

Thee oben nicht korrekt sind, sind die Spalten 2 und die Reihen sind 10, Warum?

Answer 1

Korrigiert:

Public Function removeOLEtypesOfType() As Boolean 
     On Error Resume Next 

     Dim objTopLeft As Range, objBotRight As Range _ 
      , objRange As Range, objShape As Shape 
     Set objRange = Sheet1.Range(COLUMN_HEADINGS) 
     objRange.Select 

     With Selection 
      Set objTopLeft = .Cells(1) 
      Set objBotRight = .Cells(.Cells.Count) 

      If objTopLeft Is Nothing Or objBotRight Is Nothing Then 
       MsgBox "Cannot get topleft or bottom right of range!", vbExclamation 
       removeOLEtypesOfType = False 
       Exit Function 
      End If 
      For Each objShape In ActiveSheet.Shapes 
       Dim blnTLcol As Boolean, blnTLrow As Boolean _ 
        , blnBRcol As Boolean, blnBRrow As Boolean 
       blnTLcol = (objShape.TopLeftCell.Column >= objTopLeft.Column) 
       blnTLrow = (objShape.TopLeftCell.Row >= objTopLeft.Row) 
       blnBRcol = (objShape.BottomRightCell.Column <= objBotRight.Column) 
       blnBRrow = (objShape.BottomRightCell.Row <= objBotRight.Row) 
       If blnTLcol = True And blnTLrow = True _ 
       And blnBRcol = True And blnBRrow = True Then 
        objShape.Delete 
       End If 
      Next 
     End With 
     Sheet1.Cells(1, 1).Select 
     removeOLEtypesOfType = True 
    End Function 

Dank @Ambie ich die Routine vereinfacht, kann man nicht die Antwort geben, da dies nicht das Problem war, sondern hat dazu beigetragen, den Code zu bereinigen.

Answer 2

Das scheint ein komplizierter Weg zu sein, oben links und unten rechts zu gehen, und Ihr Code wird nicht funktionieren, wenn Ihre Auswahl nicht zusammenhängende Zellen enthält. Der folgende Code könnte besser geeignet sein:

With Selection 
    Set objTopLeft = .Cells(1) 
    Set objBottomRight = .Cells(.Cells.Count) 
End With 

Answer 3

Der einfachste Weg, dies zurückzuführen ist, einen Bereich von der Shape.TopLeftCell zu schaffen, um es Shape.BottomRightCell ist und dann testen, ob sich die beiden Bereiche überschneiden.

Set rShageRange = Range(objShape.TopLeftCell, objShape.BottomRightCell)

Sub FindShapesInRange() 
    Dim objShape As Shape 
    Dim rSearch As Range, rShageRange As Range 

    Set rSearch = Range(COLUMN_HEADINGS) 

    For Each sh In ActiveSheet.Shapes 

     Set rShageRange = Range(objShape.TopLeftCell, objShape.BottomRightCell) 

     If Not Intersect(sh.TopLeftCell, rSearch) Is Nothing Then 

      Debug.Print "Shape Name: " & objShape.Name & " Shape Range: " & rShageRange.Address 

     End If 

    Next 

End Sub