Search code examples
vbarangeexcel-2003

Excel 2003, how to get top left and bottom right of range?


I have a range which I would like to check to see if any shapes are placed on it.

I found a script online (http://www.mrexcel.com/forum/excel-questions/317711-visual-basic-applications-identify-top-left-cell-selected-range.html), but it doesn't work for Excel 2003. The code I have so far which is adapated from the found script:

    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 and objBotRight are both Nothing, COLUMN_HEADINGS contains the name of the range.

I've checked intFirstCol, intFirstRow, intLastCol and intLastRow in the debugger and they are correct.

Edit... With .Address commented out both both topleft and botright ranges are returned but with .Address in, both are Nothing. The ranges returned do not appear to be for the correct locations.

For example for the supplied range:

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

The above are correct, however:

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

Thee above are not correct, the Columns are +2 and the Rows are +10, why?


Solution

  • Fixed:

        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
    

    Thanks @Ambie I simplified the routine, can't give you the answer as this wasn't the problem but has helped to clean up the code.