Excel VBA で無駄な選択範囲を縮めるコード

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