Question

我有一个范围，我想查看它是否有任何形状。

我在网上找到了一个脚本（http://www.mrexcel.com/forum/excel-questions/317711-visual-basic-applications-identify-top-left-cell-selected-range.html），但它对Excel 2003没有用。我到目前为止的代码都是根据找到的脚本改编的：

    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都是Nothing，COLUMN_HEADINGS包含范围的名称。

我在调试器中检查了intFirstCol，intFirstRow，intLastCol和intLastRow，它们是正确的。

编辑...使用.Address注释掉两个topleft和botright范围都返回但是在.Address中，两者都是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

这似乎是左上角和右下角的一种复杂方式，如果您的选择包含非连续单元格，您的代码将无法正常工作。以下代码可能更合适：

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

Answer 2

修正：

    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 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

Excel 2003，如何获得范围的左上角和右下角？

3 个答案: