Option Explicit

Private Sub WriteData(ByRef outArray() As String, ByRef sOut() As String, ByVal pos As Long, ByVal Length As Long)
    Dim i As Long
    For i = 1 To Length
        outArray(pos, i) = sOut(i)
    Next
End Sub

Private Function GetInit(ByRef this() As String, ByVal Length As Long) As Integer()
    Dim i As Long, arrCounter() As Integer
    ReDim arrCounter(1 To Length)
    For i = 1 To Length
        this(i) = "1"
        arrCounter(i) = 0
    Next
    GetInit = arrCounter
End Function

Public Sub Generate()
    Const Length As Long = 15
    Dim arrCounter() As Integer, k As Long
    Dim sOut(1 To Length) As String
    Dim vMove As Integer, vValue As Integer
    Dim i As Long, Vars(0 To 2) As String
    Dim vStopper As Long, curSum As Long
    Dim outArray() As String
    Dim row_number As Integer
    
    ReDim outArray(1 To 100, 1 To 15)
    Vars(0) = "1": Vars(1) = "Õ": Vars(2) = "2"
    arrCounter = GetInit(sOut, Length)
    k = 1
    WriteData outArray, sOut, k, Length
    vStopper = 2 * Length: curSum = 0
    Do While curSum < vStopper
        vMove = 1: i = 0
        Do While (vMove = 1) And (curSum < vStopper)
            i = i + 1
            vValue = arrCounter(i)
            curSum = curSum - vValue
            vValue = vValue + vMove
            vMove = vValue \ 3
            vValue = vValue Mod 3
            sOut(i) = Vars(vValue)
            curSum = curSum + vValue
            arrCounter(i) = vValue
        Loop
        k = k + 1: If k > 100 Then Exit Do
        If k < 50 Then
        WriteData outArray, sOut, k, Length
        ThisWorkbook.Worksheets("Лист1").Range("A2").Resize(50, 15).Value = outArray
        End If
        If k > 50 Then
        WriteData outArray, sOut, k, Length
        ThisWorkbook.Worksheets("Лист1").Range("R2").Resize(50, 15).Value = outArray
        End If
        Loop
End Sub