Sub main()
    Dim n As Long, m As Long, cnt As Long, i As Long, j As Long, mxk As Long, k As Long, clm As Long, a() As Long, out() As Long
    n = 38
    m = 6
    mxk = 3 'количество подряд возрастающих чисел
    If m < 1 Or n < m Or mxk <= 1 Then Exit Sub 'проверка достоверности данных
    cnt = WorksheetFunction.Combin(n, m) 'число сочетаний m по n
    If cnt > Rows.Count Then cnt = Rows.Count
    ReDim a(1 To m), out(1 To cnt, 1 To m)
    For i = 1 To m
        a(i) = i
    Next i
    Do
        k = 1
        For i = 2 To m
            If a(i - 1) + 1 = a(i) Then k = k + 1 Else k = 1
            If k >= mxk Then Exit For
        Next i
        If i > m Then
            If j = cnt Then
                Cells(1, clm + 1).Resize(j, m) = out
                j = 0
                clm = clm + m + 1
            End If
            j = j + 1
            For i = 1 To m
                out(j, i) = a(i)
            Next i
        End If
    Loop While NextCombin(a(), n, m)
    If j Then Cells(1, clm + 1).Resize(j, m) = out
End Sub

Function NextCombin(a() As Long, n As Long, m As Long) As Boolean 'следующее сочетание
    Dim i As Long, j As Long
    For i = m To 1 Step -1
        If a(i) < n - m + i Then
            a(i) = a(i) + 1
            For j = i + 1 To m
                a(j) = a(j - 1) + 1
            Next j
            NextCombin = True
            Exit For
        End If
    Next i
End Function

=--(
ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ({1:1:2:2:3:3};1;ПСТР(Лист2!A1;1;1));2;ПСТР(Лист2!A1;2;1));3;ПСТР(Лист2!A1;3;1))&
ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ({2:3:1:3:1:2};1;ПСТР(Лист2!A1;1;1));2;ПСТР(Лист2!A1;2;1));3;ПСТР(Лист2!A1;3;1))&
ПОДСТАВИТЬ(ПОДСТАВИТЬ(ПОДСТАВИТЬ({3:2:3:1:2:1};1;ПСТР(Лист2!A1;1;1));2;ПСТР(Лист2!A1;2;1));3;ПСТР(Лист2!A1;3;1)))

Sub Permutat(res, S1 As String, S2 As String, ByRef R As Long)
  Dim i&, L&
  L = Len(S2)
  If L < 2 Then
    res(R) = S1 & S2:  R = R + 1
  Else
    For i = 1 To L
      Permutat res, S1 + Mid(S2, i, 1), Left(S2, i - 1) + Right(S2, L - i), R
    Next
  End If
End Sub