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