Option Explicit
Sub arrays()

    Dim Ar1() As Long
    Dim Elem As Integer
    Dim i As Integer, j As Integer
    Dim R
    
'  Заполняю массив рандомными числами и записываю их в столбец 1

    Elem = InputBox("Введите размер массива ")
    ReDim Ar1(1 To Elem, 0)
    For i = 1 To Elem
        Ar1(i, 0) = CLng(Rnd * 100000)
    Next i
    Range(Cells(1, 1), Cells(Elem, 1)) = Ar1()

' Сортирую массив перебором и записываю отсортированный массив в столбец 3
    
    For i = 1 To Elem - 1
        j = i
        Do While Ar1(j + 1, 0) < Ar1(j, 0) & j > 0
            R = Ar1(j, 0)
            Ar1(j, 0) = Ar1(j + 1, 0)
            Ar1(j + 1, 0) = R
            j = j - 1
        Loop
    Next i
     
    Range(Cells(1, 3), Cells(Elem, 3)) = Ar1()
    
    
End Sub