【Excel】無駄な選択範囲を縮める⑥【VBA】

大量の閉じカッコで終端されて、なんだかLispっぽくなってる箇所とかありますが、とりあえず動くのでいいでしょう。

Function DecreaseRange(a1 As Range) As Range
    
    Set DecreaseRange = _
            DecreaseLeft( _
            DecreaseRight( _
            DecreaseUpper( _
            DecreaseBottom( _
            DecreaseToUsedRange(a1)))))

End Function


Function DecreaseToUsedRange(a1 As Range) As Range
    
    With a1
        r1 = .Row
        c1 = .Column
        r2 = .Rows.Count + r1 - 1
        c2 = .Columns.Count + c1 - 1
    End With
    
    With ActiveSheet.UsedRange
        ur1 = .Row
        uc1 = .Column
        ur2 = .Rows.Count + ur1 - 1
        uc2 = .Columns.Count + uc1 - 1
    End With
    
    b = (r1 > ur2) Or (c1 > uc2) Or _
        (r2 < ur1) Or (c2 < uc1) Or _
        (ur2 = 1) Or (uc2 = 1)
    If b Then
        
        'UsedRangeの外側が与えられた場合の処理
        '左上隅のセルを返す
        
        NewRow1 = r1
        NewColumn1 = c1
        NewRow2 = r1
        NewColumn2 = c1
        
    Else
    
        'UsedRangeの内側が与えられた場合の処理
        
        If r1 < ur1 Then
            NewRow1 = ur1
        Else
            NewRow1 = r1
        End If
        
        If c1 < uc1 Then
            NewColumn1 = uc1
        Else
            NewColumn1 = c1
        End If
        
        If r2 > ur2 Then
            NewRow2 = ur2
        Else
            NewRow2 = r2
        End If
        
        If c2 > uc2 Then
            NewColumn2 = uc2
        Else
            NewColumn2 = c2
        End If
        
    End If
    
    Set DecreaseToUsedRange = _
        Range(Cells(NewRow1, NewColumn1), _
              Cells(NewRow2, NewColumn2))
              
End Function


Function DecreaseBottom(a1 As Range) As Range
    
    With a1
        r1 = .Row
        c1 = .Column
        r2 = .Rows.Count + r1 - 1
        c2 = .Columns.Count + c1 - 1
    End With
    
    NewRow = r1
    For c = c1 To c2
        
        If Len(Cells(r2, c)) > 0 Then
            NewRow = r2
            Exit For
        End If
        
        r = Cells(r2, c).End(xlUp).Row
        If r > NewRow Then
            NewRow = r
        End If
        
    Next c

    Set DecreaseBottom = _
        Range(Cells(r1, c1), Cells(NewRow, c2))

End Function


Function DecreaseUpper(a1 As Range) As Range
    
    With a1
        r1 = .Row
        c1 = .Column
        r2 = .Rows.Count + r1 - 1
        c2 = .Columns.Count + c1 - 1
    End With
    
    Set f = Application.WorksheetFunction
    
    NewRow = r2
    For r = r1 To r2
        Set x = Range(Cells(r, c1), Cells(r, c2))
        If f.CountA(x) > 0 Then
            NewRow = r
            Exit For
        End If
    Next r
    
    Set f = Nothing
    
    Set DecreaseUpper = _
        Range(Cells(NewRow, c1), Cells(r2, c2))

End Function


Function DecreaseRight(a1 As Range) As Range
    
    With a1
        r1 = .Row
        c1 = .Column
        r2 = .Rows.Count + r1 - 1
        c2 = .Columns.Count + c1 - 1
    End With
    
    Set f = Application.WorksheetFunction
    
    NewColumn = c1
    For c = c2 To c1 Step -1
        Set x = Range(Cells(r1, c), Cells(r2, c))
        If f.CountA(x) > 0 Then
            NewColumn = c
            Exit For
        End If
    Next c
    
    Set f = Nothing
    
    Set DecreaseRight = _
        Range(Cells(r1, c1), Cells(r2, NewColumn))

End Function


Function DecreaseLeft(a1 As Range) As Range
    
    With a1
        r1 = .Row
        c1 = .Column
        r2 = .Rows.Count + r1 - 1
        c2 = .Columns.Count + c1 - 1
    End With
    
    Set f = Application.WorksheetFunction
    
    NewColumn = c2
    For c = c1 To c2
        Set x = Range(Cells(r1, c), Cells(r2, c))
        If f.CountA(x) > 0 Then
            NewColumn = c
            Exit For
        End If
    Next c
    
    Set f = Nothing
    
    Set DecreaseLeft = _
        Range(Cells(r1, NewColumn), Cells(r2, c2))

End Function

【2011/06/01追記】
　DecreaseToUsedRange関数で、一行目のみ或いは一列目のみを選択した際にA1セルのみを返してしまうと言うバグを発見。「ur2 = 1」と「uc2 = 1」と言う判定ロジックがまずかった。判定ロジックを「a1.Address = "A1"」に変えればOK。修正版のコードは後日…(^_^;)