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

　無駄な選択範囲を縮める関数として、

・ReduceRangeR -> 下方の無駄な選択範囲を縮める
・ReduceRangeC -> 右方の無駄な選択範囲を縮める
・xUsedRange -> "UsedRange"の外側の範囲を縮める

を定義しました。

　上記三つを更にまとめて、関数"ReduceRange"を定義します。

Sub HowToUse()
    ReduceRange(Selection).Select
End Sub

Function ReduceRange(a1 As Range) As Range
    'ただ単に三つの関数を束ねるだけの関数
    'xUsedRangeを最初に適用すると最も効率が良い(多分)
    Set ReduceRange = ReduceRangeR(ReduceRangeC(xUsedRange(a1)))
End Function

Private Function xUsedRange(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
    
    If (r1 > ur2) Or (c1 > uc2) Or (r2 < ur1) Or (c2 < uc1) Or (ur2 = 1) Or (uc2 = 1) Then
        'UsedRangeの外側が与えられた場合の処理
        '(左上隅のセルを返す)
        NewRow1 = r1
        NewColumn1 = c1
        NewRow2 = r1
        NewColumn2 = c1
        
        GoTo xxx
    End If
    
    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
    
xxx:
    Set xUsedRange = Range(Cells(NewRow1, NewColumn1), Cells(NewRow2, NewColumn2))
End Function

Private Function ReduceRangeC(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
        If f.CountA(Range(Cells(r1, c), Cells(r2, c))) > 0 Then
            NewColumn = c
            Exit For
        End If
    Next c
    
    Set ReduceRangeC = Range(Cells(r1, c1), Cells(r2, NewColumn))
End Function

Private Function ReduceRangeR(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 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 ReduceRangeR = Range(Cells(r1, c1), Cells(NewRow, c2))
End Function

　コードの分かりにくそうな所にコメントを少々追加。
　ついでに、"Exit For"を使うべきところで"GoTo"を使っていた箇所を修正。

　実行前

　実行後

xUsedRange
　黄、紫、青の部分までサイズを縮小

ReduceRangeC
　黄、紫の部分までサイズを縮小

ReduceRangeR
　黄の部分までサイズを縮小

　ここまで来ると、上方と左方の空白部分も最適化したくなってきます。

　要らないような気もするけど…。