Sub main()
    Dim blntmp As Variant, txttmp, CL As Long
    Dim vartmp As Variant, arrtmp()
    Dim Celltmp As range
    Dim x As Long, y As Long
    Dim i As Long, j As Long
    Set This_Wbk = ActiveWorkbook
    Set acsheet = ActiveSheet
    If Worksheet_Y_N("База") = False Then
        MsgBox "Отсутствует лист с базой данных профилей"
        End
    End If
    Set Celltmp = This_Wbk.Worksheets("База").UsedRange
    vartmp = range_to_var(Celltmp)
    x = UBound(vartmp, 1): y = UBound(vartmp, 2)
    ReDim Pr_Base1(1 To x / 2)
    ReDim GOST1(1 To x / 2)
    CL = 0
    For i = 1 To x Step 2
        ReDim arrtmp(0)
        If (i + 1) / 2 = 23 Then Stop

        If Replace(vartmp(i + 1, 1), " ", "") <> "" And Replace(vartmp(i, 1), " ", "") <> "" Then
            arrtmp(0) = Trim(vartmp(i, 1))
            GOST1((i + 1) / 2) = Trim(vartmp(i + 1, 1))
            For j = 2 To y
                If vartmp(i, j) <> Empty And vartmp(i + 1, j) <> Empty Then
                    CL = CL + 1
                    ReDim Preserve arrtmp(CL)
                    arrtmp(CL) = Trim(vartmp(i, j)) & vbCrLf & Trim(vartmp(i + 1, j))

                Else

                    Exit For
                End If
            Next j
            Pr_Base1((i + 1) / 2) = arrtmp

        End If
    Next i
    BubbleSort Pr_Base1, GOST1
    UserForm1.Show
    Exit Sub
err_ch:
    MsgBox "Ошибка N " & Err.Number & vbCrLf & Err.Description
End Sub