Процедура "Умное выделение" для выделения столбцов в пределах диапазона с данными (Решено)

Sub SmartSelection()
Dim i As Long, RAC As Range, LHoriz As Boolean, y As Long, j As Long
Dim RCol As Long, LAC As Range, ineqCols As Boolean
Dim RHoriz As Boolean, rng As Range, AR As Range, cntCols As Long
    cntCols = Selection.Columns.Count
    Set LAC = Selection(1)
    Set RAC = LAC.Offset(0, cntCols - 1)
    RCol = RAC.Column
    ineqCols = cntCols > 1 ' неравенство столбиков. True, если первый
    ' и последний столбики диапазона - это разные столбики.
    
    ' На случай, если первая строка выделения расположена выше диапазона
    ' считаем строки j
    For j = 0 To Selection.Rows.Count - 1
        If ineqCols Then ' Для диапазонов из нескольких столбиков
            i = 0
            ' отдельно проверяем наличие данных влево от выделения,
            ' считаем только до первого столбика
            Do Until LHoriz Or RHoriz Or i = LAC.Column - 1
                i = i + 1
                If Len(LAC.Offset(j, -i).Value) Then
                    LHoriz = True
                    Set AR = LAC.Offset(j, -i)
                    Exit For
                End If
            Loop
            ' Если влево данных не нашли, смотрим вправо
            If Not LHoriz Then
                i = 0
                Do Until RHoriz Or i = 20
                    i = i + 1
                    If Len(RAC.Offset(j, i).Value) Then
                        RHoriz = True
                        Set AR = RAC.Offset(j, i)
                        Exit For
                    End If
                Loop
            End If
            ' Если данных не нашли ни влево, ни в право, и это последняя строка
            ' диапазона, то завершаем процедуру.
            If Not LHoriz And Not RHoriz And j = Selection.Rows.Count - 1 Then
                Exit Sub
            End If
        Else ' Для диапазонов из одного столбика
            i = 0
            ' отдельно проверяем наличие данных влево от выделения,
            ' считаем только до первого столбика
            Do Until LHoriz Or RHoriz Or i = LAC.Column - 1
                i = i + 1
                If Len(LAC.Offset(j, -i).Value) Then
                    LHoriz = True
                    Set AR = LAC.Offset(j, -i)
                    Exit For
                End If
            Loop
            ' Если влево данных не нашли, смотрим вправо
            If Not LHoriz Then
                i = 0
                Do Until RHoriz Or i = 20
                    i = i + 1
                    If Len(LAC.Offset(j, i).Value) Then
                        RHoriz = True
                        Set AR = LAC.Offset(j, i)
                        Exit For
                    End If
                Loop
            End If
            ' Если данных не нашли ни влево, ни в право, и это последняя строка
            ' диапазона, то завершаем процедуру.
            If Not LHoriz And Not RHoriz And j = Selection.Rows.Count - 1 Then
                Exit Sub
            End If
        End If
    Next j
    ' Теперь, когда нашли ячейку с данными, будем проверять весь её столбец
    Set AR = Range(Cells(AR.Row, AR.Column), Cells(Range("A:A").Rows.Count - AR.Row, AR.Column))
    For Each rng In AR
        With rng
            ' Если в текущей ячейке есть данные, а в двух ячейках под ней данных уже нет,
            ' то считаем эту ячейку последней ячейкой диапазона
            If Len(.Value) And (.Offset(1, 0).Value) = 0 And (.Offset(2, 0).Value) = 0 Then
                Range(Cells(LAC.Row, LAC.Column), Cells(.Row, RCol)).Select
                Exit Sub
            End If
        End With
    Next
End Sub

Sub SrgSelectStairs()
'выделение лесенкой
Dim S As String, Arr() As String, I As Integer, J As Integer
S = Selection.Address
Arr = Split(S, ",")
S = ""
For J = 0 To UBound(Arr)
  I = InStrRev(Arr(J), "$")
  S = S & Arr(J) & ":" & Left(Arr(J), I) & Rows.Count & ","
Next
Range(Arr(0)).Select
Range(Left(S, Len(S) - 1)).Select
End Sub

Sub Rovno()
Dim I As Integer, J As Integer, LastRow As Long
'для столбца справа, если нужен слева, то J-1
J = Selection.Column: I = Selection.Row
LastRow = Cells(Rows.Count, J + 1).End(xlUp).Row
Range(Cells(1, J), Cells(LastRow, J)).Select
End Sub
 
Sub SrgSelect()
Dim S As String
S = Selection.Address
I = InStrRev(S, "$")
Range(Left(S, I) & Rows.Count).Select
End Sub

Public Sub select_left_right()
Dim cName As String, c2Name, rng As String
    cName = Mid(Selection.Address, 2, 1)
    c2Name = Mid(Selection.Offset(0, ((Selection.Columns.Count) - 1)).Address, 2, 1)
    rng = Range(cName & ":" & c2Name).Address
    If Not (IsEmpty(Selection.End(xlToLeft)) Or IsEmpty(Selection.End(xlToLeft).End(xlDown))) Then
        Intersect(Range(Selection.End(xlToLeft).End(xlDown), Selection), Range(rng)).Select
    ElseIf Not (IsEmpty(Selection.End(xlToRight)) Or IsEmpty(Selection.End(xlToRight).End(xlDown))) Then
        Intersect(Range(Selection.End(xlToRight).End(xlDown), Selection), Selection.EntireColumn).Select
    End If
End Sub

Public Sub select_left_right_sclmn()
    Dim i  As Integer
    i = Selection.Columns.Count
    Selection.Cells(1, 1).Select
    If Not (IsEmpty(Selection.End(xlToLeft)) Or IsEmpty(Selection.End(xlToLeft).End(xlDown))) Then
        Intersect(Range(Selection.End(xlToLeft).End(xlDown), Selection), Selection.EntireColumn).Select
    ElseIf Not (IsEmpty(Selection.End(xlToRight)) Or IsEmpty(Selection.End(xlToRight).End(xlDown))) Then
        Intersect(Range(Selection.End(xlToRight).End(xlDown), Selection), Selection.EntireColumn).Select
    End If
    Selection.Resize(Selection.Rows.Count, i).Select
End Sub