大量の閉じカッコで終端されて、なんだか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。修正版のコードは後日…(^_^;)
