2010/6/20 にアップして 2011/06/01 に「修正版は後日」と書いて以来放置。
修正版です…。
図らずもあれから使用実績だけは重ねたので今度は多分大丈夫でしょう。
一番上の test_DecreaseRange がテストコードです。
引数 Range を受けて、データの入っていない空白セルを除いた Range を返します。
データの入ったワークシートで行全体や列全体、全セル等を選択して実行してみて下さい。
'---------------------------------------------------
'DecreaseToUsedRangeを最初に適用すると効率が良いはず
'---------------------------------------------------
Private Sub test_DecreaseRange()
DecreaseRange(selection).Select
End Sub
Function DecreaseRange(a1 As Range) As Range
Set DecreaseRange = _
DecreaseLeft( _
DecreaseRight( _
DecreaseUpper( _
DecreaseBottom( _
DecreaseToUsedRange(a1)))))
End Function
Function DecreaseToUsedRange(a1 As Range) As Range
r1 = a1.Row
c1 = a1.Column
r2 = a1.Rows.Count + r1 - 1
c2 = a1.Columns.Count + c1 - 1
Set ur = ActiveSheet.UsedRange
r3 = ur.Row
c3 = ur.Column
r4 = ur.Rows.Count + r3 - 1
c4 = ur.Columns.Count + c3 - 1
b = (r1 > r4) Or (c1 > c4) Or _
(r2 < r3) Or (c2 < c3) Or _
a1.Address = "A1"
If b Then
'UsedRangeの外側が与えられた場合の処理
'左上隅のセルを返す
NewRow1 = r1
NewColumn1 = c1
NewRow2 = r1
NewColumn2 = c1
Else
'UsedRangeの内側が与えられた場合の処理
If r1 < r3 Then
NewRow1 = r3
Else
NewRow1 = r1
End If
If c1 < c3 Then
NewColumn1 = c3
Else
NewColumn1 = c1
End If
If r2 > r4 Then
NewRow2 = r4
Else
NewRow2 = r2
End If
If c2 > c4 Then
NewColumn2 = c4
Else
NewColumn2 = c2
End If
End If
Set x = Range(Cells(NewRow1, NewColumn1), _
Cells(NewRow2, NewColumn2))
Set DecreaseToUsedRange = x
End Function
Function DecreaseBottom(a1 As Range) As Range
r1 = a1.Row
c1 = a1.Column
r2 = a1.Rows.Count + r1 - 1
c2 = a1.Columns.Count + c1 - 1
NewRow = r1
For c = c1 To c2
If IsError(Cells(r2, c)) Then
NewRow = r2
Exit For
End If
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 x = Range(Cells(r1, c1), Cells(NewRow, c2))
Set DecreaseBottom = x
End Function
Function DecreaseUpper(a1 As Range) As Range
r1 = a1.Row
c1 = a1.Column
r2 = a1.Rows.Count + r1 - 1
c2 = a1.Columns.Count + c1 - 1
Set f = Application.WorksheetFunction
NewRow = r2
For r = r1 To r2
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 x = Range(Cells(NewRow, c1), Cells(r2, c2))
Set DecreaseUpper = x
End Function
Function DecreaseRight(a1 As Range) As Range
r1 = a1.Row
c1 = a1.Column
r2 = a1.Rows.Count + r1 - 1
c2 = a1.Columns.Count + c1 - 1
Set f = Application.WorksheetFunction
NewColumn = c1
For c = c2 To c1 Step -1
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 x = Range(Cells(r1, c1), Cells(r2, NewColumn))
Set DecreaseRight = x
End Function
Function DecreaseLeft(a1 As Range) As Range
r1 = a1.Row
c1 = a1.Column
r2 = a1.Rows.Count + r1 - 1
c2 = a1.Columns.Count + c1 - 1
Set f = Application.WorksheetFunction
NewColumn = c2
For c = c1 To c2
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 x = Range(Cells(r1, NewColumn), Cells(r2, c2))
Set DecreaseLeft = x
End Function
