Option Explicit

Sub Дозаполнить()
    If TypeName(Selection) <> "Range" Then Exit Sub
    
    Dim rr As Range
    On Error Resume Next
    Set rr = Intersect(Selection, ActiveSheet.UsedRange).Areas(1)
    On Error GoTo 0
    If rr Is Nothing Then Exit Sub
    If rr.Cells.CountLarge = 1 Then Exit Sub
    
    Dim arr As Variant
    arr = rr.FormulaR1C1
    arr = GetArr(arr)
    
    rr.FormulaR1C1 = arr
End Sub

Private Function GetArr(arr As Variant) As Variant
    Dim brr As Variant
    ReDim brr(1 To UBound(arr, 1), 1 To UBound(arr, 2))
    
    Dim crr As Variant
    ReDim crr(1 To UBound(arr, 2))
    
    
    Dim ya As Long
    Dim xa As Long
    For ya = 1 To UBound(arr, 1)
        For xa = 1 To UBound(arr, 2)
            If arr(ya, xa) <> "" Then
                crr(xa) = arr(ya, xa)
                brr(ya, xa) = crr(xa)
                Exit For
            End If
            brr(ya, xa) = crr(xa)
        Next
    Next
    GetArr = brr
End Function