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 в отладчике, и они верны.

Редактировать ... С .Address прокомментировал оба варианта: topleft и botright диапазоны возвращаются, но с .Address in, both are Nothing. Возвращаемые диапазоны не отображаются для правильных местоположений.

Например, для поставляемого диапазона:

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