Excel 2003, 왼쪽 위 및 아래 오른쪽 범위를 얻는 방법?

Question

어떤 모양이 그 위에 놓여 있는지 확인하고 싶은 범위가 있습니다.

나는 (http://www.mrexcel.com/forum/excel-questions/317711-visual-basic-applications-identify-top-left-cell-selected-range.html) 온라인 스크립트를 발견하지만, 엑셀 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을 사용하면 둘 다 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.BottomRightCell의에 Shape.TopLeftCell의 범위를 만든 다음 두 개의 범위가 교차하는지 테스트하는 것입니다.

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