В поисках панграмм [excel, vba]

Option Base 1
Sub Pangramma_na_baze()
    Const MaxKolPangramm = 1 ' Чтобы не набирать огромное число комбинаций слов для среднего числа букв
    Dim i&, ii%, j%, k%, A, B, PanKol%, strokaVhod$, KolSlov&, S$, Z$, Novoe As Boolean
    Dim KolSlovStolb&(10), Pangramma$(MaxKolPangramm), Predlojenie$(16), SlovoRow&(0 To 16), SlovoCol%(0 To 16)
    Dim Obrazec() As Boolean, OstatokObr() As Boolean, OstatokObrOld(), Tek() As Boolean
    ReDim Obrazec(33), OstatokObr(33), OstatokObrOld(0 To 33), Tek(33)
    strokaVhod = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя" ' "ад и ёж" '"а я ёж" ' "абвгдеёжзя" '"абвгдеёжзийклмнопрстуфхцчшщъыьэюя"
    strokaVhod = LCase(strokaVhod) ' работаем со строчными буквами
    ' Цифрограмма слова это массив от 1до 33, 1-32 = а-я, 33=ё . True если есть буква в слове.
    Cifrogramma strokaVhod, Obrazec
    With Worksheets("Baza")
        ' Массив с базой слов. Номер столбца от 1 до 10 равен числу букв в словах. Каждый столбец упорядочен по алфавиту.
        A = .UsedRange.Value
        For j = 1 To 10
            KolSlovStolb(j) = .Cells(.Rows.Count, j).End(xlUp).Row
        Next
    End With
    ReDim B(UBound(A), 10) ' Массив массивов цифрогамм слов из базы
    For j = 1 To 10
        For i = 1 To KolSlovStolb(j)
            ReDim Tek(33)
            Cifrogramma A(i, j), Tek
            B(i, j) = Tek
        Next i
    Next j
    '--- перебор слов в базе------------
    For PanKol = 1 To MaxKolPangramm
        OstatokObr = Obrazec
        KolSlov = 0
        Erase Predlojenie
        'For k = 0 To 16: SlovoRow(k) = 0: SlovoCol(k) = 10: Next k
        '##############################################
        For k = 0 To 16: SlovoRow(k) = 0: SlovoCol(k) = 5: Next k ' оптимизация для 33 букв
        KolSlovStolb(1) = 0: KolSlovStolb(2) = 0 ' оптимизация для 33 букв
        '##############################################
        Do
            'For j = SlovoCol(KolSlov) To 1 Step -1
            For j = SlovoCol(KolSlov) To 1 Step -1  ' оптимизация для 33 букв
                ii = IIf(j = SlovoCol(KolSlov), SlovoRow(KolSlov) + 1, 1)
                For i = ii To KolSlovStolb(j)
                    If ObrazecMinusSlovo(OstatokObr, B(i, j), Tek) Then
                       ' Stop '+++++++++++
                        SlovoRow(KolSlov) = i
                        SlovoCol(KolSlov) = j
                        OstatokObrOld(KolSlov) = OstatokObr
                        OstatokObr = Tek
                        KolSlov = KolSlov + 1
                        Predlojenie(KolSlov) = A(i, j)
                        '++++++++++++++++
                        Debug.Print KolSlov,
                        For k = 1 To KolSlov
                            Debug.Print Predlojenie(k) & " ";
                        Next k
                        Debug.Print
                        '++++++++++++++++
                        If NeOstalosBukv(OstatokObr) Then
                            S = ""
                            For k = 1 To KolSlov
                                S = S & Predlojenie(k) & " "
                            Next k
                            S = Trim(S)
                            Novoe = True
                            For ii = 1 To PanKol - 1
                                If Pangramma(ii) = S Then Novoe = False: Exit For
                            Next ii
                            If Novoe Then
                                For k = 1 To KolSlov
                                    Pangramma(PanKol) = Predlojenie(k)
                                Next k
                                Pangramma(PanKol) = S
                                Exit Do
                            End If
                        End If
                    End If
                    '+++++++++++++++++++++
                    DoEvents  '+++++++++
                    '+++++++++++++++++++++
                Next i
                'Stop '+++++++++++
            Next j
            SlovoRow(KolSlov) = 0
            'SlovoCol(KolSlov) = 10
            '##############################################
            SlovoCol(KolSlov) = 5 ' оптимизация для 33 букв
            '##############################################
            KolSlov = KolSlov - 1
            If KolSlov < 0 Then Exit Do
            OstatokObr = OstatokObrOld(KolSlov)
        Loop
    Next PanKol
    '-----------------------------------
    S = ""
    For i = 1 To MaxKolPangramm
        S = S & Pangramma(i) & vbCrLf
    Next
    'MsgBox S
    Debug.Print S
End Sub
 
Function ObrazecMinusSlovo(ByVal Obrazec, Slovo, Ostatok) As Boolean
    Dim i%
    ReDim Ostatok(33)
    Ostatok = Obrazec
    For i = 1 To 33
        If Obrazec(i) = False And Slovo(i) Then
            Ostatok = Obrazec
            Exit Function
        ElseIf Obrazec(i) And Slovo(i) Then
            Ostatok(i) = False
        End If
    Next
    ObrazecMinusSlovo = True
End Function
 
Function NeOstalosBukv(Obrazec) As Boolean
    Dim i%
    For i = 1 To 33
        If Obrazec(i) Then Exit Function
    Next
    NeOstalosBukv = True
End Function
 
Sub Cifrogramma(S, Obrazec)
    Dim i%, B$
    For i = 1 To Len(S)
        B = Mid(S, i, 1)
        Select Case B
            Case "ё"
               Obrazec(33) = True
            Case "а" To "я", "ё"
               Obrazec(Asc(B) - 223) = True
        End Select
    Next i
End Sub

Option Base 1
Dim Ch
Sub Pangramma_na_baze()
    Const MaxKolPangramm = 1 ' Чтобы не набирать огромное число комбинаций слов для среднего числа букв
    Dim i&, ii%, j%, k%, kk&, A, B, PanKol%, strokaVhod$, KolSlov&, S$, Z$, Novoe As Boolean
    Dim KolSlovStolb&(10), Pangramma$(MaxKolPangramm), Predlojenie$(16), SlovoRow&(0 To 16), SlovoCol%(0 To 16)
    Dim Obrazec() As Boolean, OstatokObr() As Boolean, OstatokObrOld(), Tek() As Boolean
    ReDim Obrazec(33), OstatokObr(33), OstatokObrOld(0 To 33), Tek(33)
    strokaVhod = "абвгдеёжзийклмнопрстуфхцчшщъыьэюя" ' "ад и ёж" '"а я ёж" ' "абвгдеёжзя" '"абвгдеёжзийклмнопрстуфхцчшщъыьэюя"
    strokaVhod = LCase(strokaVhod) ' работаем со строчными буквами
    ' Цифрограмма слова это массив от 1до 33, 1-32 = а-я, 33=ё . True если есть буква в слове.
    Cifrogramma strokaVhod, Obrazec
    'Номера позиций в цифрограмме в порядке понижения частотности букв
    ' о е а и н т с р в л к м д п у я ы ь г з б ч й х ж ш ю ц щ э ф ъ ё
    Ch = Array(15, 6, 1, 9, 14, 19, 18, 17, 3, 12, 11, 13, 5, 16, 20, 32, 28, 29, 4, 8, 2, 24, 10, 22, 7, 25, 31, 23, 26, 30, 21, 27, 33)
    With Worksheets("Baza")
        ' Массив с базой слов. Номер столбца от 1 до 10 равен числу букв в словах. Каждый столбец упорядочен по алфавиту.
        A = .UsedRange.Value
        For j = 1 To 10
            KolSlovStolb(j) = .Cells(.Rows.Count, j).End(xlUp).Row
        Next
    End With
    ReDim B(UBound(A), 10) ' Массив массивов цифрогамм слов из базы
    For j = 1 To 10
        For i = 1 To KolSlovStolb(j)
            ReDim Tek(33)
            Cifrogramma A(i, j), Tek
            B(i, j) = Tek
        Next i
    Next j
    '--- перебор слов в базе------------
    For PanKol = 1 To MaxKolPangramm
        OstatokObr = Obrazec
        KolSlov = 0
        Erase Predlojenie
        'For k = 1 To 16: SlovoRow(k) = 0: SlovoCol(k) = 10: Next k
        '##############################################             оптимизация для 33 букв
        For k = 1 To 16: SlovoRow(k) = 0: SlovoCol(k) = 5: Next k ' оптимизация для 33 букв
        KolSlovStolb(1) = 0: KolSlovStolb(2) = 0            ' оптимизация для 33 букв
        '############################################## оптимизация для 33 букв
        If PanKol = 1 Then SlovoRow(0) = 0: SlovoCol(0) = SlovoCol(1)
        Do
            For j = SlovoCol(KolSlov) To 1 Step -1
                ii = IIf(j = SlovoCol(KolSlov), SlovoRow(KolSlov) + 1, 1)
                For i = ii To KolSlovStolb(j)
                    If EstVObrazce(OstatokObr, B(i, j)) Then
                        ObrazecMinusSlovo OstatokObr, B(i, j), Tek
                       ' Stop '+++++++++++
                        SlovoRow(KolSlov) = i
                        SlovoCol(KolSlov) = j
                        OstatokObrOld(KolSlov) = OstatokObr
                        OstatokObr = Tek
                        KolSlov = KolSlov + 1
                        Predlojenie(KolSlov) = A(i, j)
                        If NeOstalosBukv(OstatokObr) Then
                            S = ""
                            For k = 1 To KolSlov
                                S = S & Predlojenie(k) & " "
                            Next k
                            S = Trim(S)
                            Novoe = True
                            For ii = 1 To PanKol - 1
                                If Pangramma(ii) = S Then Novoe = False: Exit For
                            Next ii
                            If Novoe Then
                                For k = 1 To KolSlov
                                    Pangramma(PanKol) = Predlojenie(k)
                                Next k
                                Pangramma(PanKol) = S
                                Exit Do
                            End If
                        End If
                    End If
                    '+++++++++++++++++++++
                    DoEvents  '+++++++++
                    '+++++++++++++++++++++
                Next i
                'Stop '+++++++++++
            Next j
            kk = kk + 1
            '++++++++++++++++
            If kk Mod 10 = 0 Then
                Debug.Print kk,
                For k = 1 To KolSlov
                    Debug.Print Predlojenie(k) & " ";
                Next k
                Debug.Print
            End If
            '++++++++++++++++
            SlovoRow(KolSlov) = 0
            'SlovoCol(KolSlov) = 10
            '############################################## ' оптимизация для 33 букв
            SlovoCol(KolSlov) = 5 ' оптимизация для 33 букв
            '############################################## ' оптимизация для 33 букв
            KolSlov = KolSlov - 1
            If KolSlov < 0 Then Exit Do
            OstatokObr = OstatokObrOld(KolSlov)
            '+++++++++++++++ ' Ограничитель итераций
            If kk > 100000 Then End
            '+++++++++++++++
        Loop
    Next PanKol
    '-----------------------------------
    S = ""
    For i = 1 To MaxKolPangramm
        S = S & Pangramma(i) & vbCrLf
    Next
    'MsgBox S
    Debug.Print S
End Sub
 
Function EstVObrazce(Obrazec, Slovo) As Boolean
    Dim i%
    For i = 1 To 33
        If Obrazec(Ch(i)) = False And Slovo(Ch(i)) Then Exit Function
    Next
    EstVObrazce = True
End Function
 
Function ObrazecMinusSlovo(Obrazec, Slovo, Ostatok) As Boolean
    Dim i%
    Ostatok = Obrazec
    For i = 1 To 33
        If Obrazec(i) And Slovo(i) Then Ostatok(i) = False
    Next
    ObrazecMinusSlovo = True
End Function
 
Function NeOstalosBukv(Obrazec) As Boolean
    Dim i%
    For i = 33 To 1 Step -1
        If Obrazec(i) Then Exit Function
    Next
    NeOstalosBukv = True
End Function
 
Sub Cifrogramma(S, Obrazec)
    Dim i%, B$
    For i = 1 To Len(S)
        B = Mid(S, i, 1)
        Select Case B
            Case "ё"
               Obrazec(33) = True
            Case "а" To "я", "ё"
               Obrazec(Asc(B) - 223) = True
        End Select
    Next i
End Sub