Excel 2003，如何獲取範圍的左上角和右下角？

Question

我有一個範圍，我想檢查是否有任何形狀放在它上面。

我發現了一個腳本在線（http://www.mrexcel.com/forum/excel-questions/317711-visual-basic-applications-identify-top-left-cell-selected-range.html），但它不提供Excel 2003年我迄今其從發現腳本adapated工作代碼：

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和objBotRight都沒有，COLUMN_HEADINGS包含範圍的名稱。

我在調試器中檢查了intFirstCol，intFirstRow，intLastCol和intLastRow，它們都是正確的。

編輯... With .Address註釋掉了兩個topleft和botright範圍都返回，但與.Address in，都是沒有。返回的範圍似乎不是用於正確的位置。

例如，對於所提供的範圍：

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

以上是正確的，但是：

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

以上禰是不正確的，列2和行是10，爲什麼？

Answer 1

修正：

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 

感謝@Ambie我簡化了程序，不能給你答案，因爲這是沒有問題的，但有助於清理代碼。

Answer 2

這看起來是一種複雜的方式來獲取左上角和右下角，如果您的選擇包含非連續的單元格，您的代碼將無法工作。下面的代碼可能更適合：

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

Answer 3

到由於這種最簡單的方法是創建一個從Shape.TopLeftCell一個範圍很Shape.BottomRightCell，然後進行測試，看看這兩個區域相交。

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