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

Узнай цену своей работы

Формулировка задачи:

ПРИВЕТСТВИЕ ЧЕГО МЫ ХОТИМ? На входе имеем базу слов, на выходе – все возможные по условиям панграммы. УСЛОВИЯ 1. Панграммы ищем для n букв (первостепенно – 33). 2. Все буквы в конечном наборе слов предложении встречаются ровно по 1 разу. 3. Исходная база содержит слова с повторяющимися буквами и/или всякими ненужными символами (какими конкретно – не известно). МОЙ ВКЛАД 1. Нашел формулу массива для первоначальной сортировки базы: {=ИЛИ((ДЛСТР(A2)-ДЛСТР(ПОДСТАВИТЬ(СТРОЧН(A2);СИМВОЛ(СТРОКА($1:$255));"")))>1)} Для слов с повторяющимися буквами выдает ИСТИНА. Далее сортируем, все строки с ИСТИНА в расход, оставляем одни только ЛОЖИ. 2. Нашел макрос на очищение нашей уже обрезанной базы от всякой нечисти - достаточно указать список лишних символов. Проблема: база большая, какой там конкретно мусор – не известно. Искал макрос который бы выводил список всех символов (по 1 шт), имеющихся на листе, не нашел. 3. Подумал над алгоритмом для работы с результирующей базой. ВОЗМОЖНЫЙ АЛГОРИТМ 1. Выводим все буквы слова функцией ПСТР. 2. Создаем двоичный код каждого слова функцией СЧЁТЕСЛИ. 3. Переводим в десятичную систему счисления, поочередно умножая на 2^m (m<33) и затем суммируя. Можно, конечно, объединить все 0 и 1 в громоздкое 33-ёхзначное число, которое потом перегнать функцией ДВВДЕС. Имеем столбец #1 с.. назовем это численной записью числа. 4. Сортируем базу слов по столбцу #1. Имеем численную запись чисел по возрастанию/убыванию. 5. Моя остановочка. Дело за малым – научиться выделять из столбца #1 диапазон слов с разными буквами, сумма численных значений которых равна (2^33)-1 = 8589934591 (для 33-ёх букв, не говоря уже о количестве вариаций для 32, 31 и т.д.) ЛЁД ТРОНУЛСЯ Нашел такую весчь, называется подбор слагаемых под нужную сумму. Является частным случаем «задачи о рюкзаке». Наиболее оптимальные на мой беглый взгляд алгоритмы обитают тута (http://www.excelworld.ru/forum/10-5196-1). Вот если бы эту штуку как-то применить в нашей задаче. Описанный мною выше возможный алгоритм можно упростить до записи слов в двоичном коде. Далее: 1. Берем первое слово, сверяем с каждым на наличие одинаковых букв (единичек). Отбираем массив #1(1) слов с буквами, которых нет в нашем первом слове. 2. Берем первое слово из массива #1(1), сверяем с каждым из массива #1(1) на наличие одинаковых букв (единичек). Отбираем массив #2(1) слов с буквами, которых нет в нашем первом слове из массива #1(1). 3. Повторяем операцию до тех пор, пока конечный массив не превратится в слово. Суммируем двоичный код получившейся выборки и проверяем на равенство 11…11 (33 шт). 4. Возвращаемся на массив уровнем выше (предпоследний), берем оттуда второе слово и делаем все то же самое (опускаемся вниз, проверяем на равенство новую выборку). Если слов в нем больше двух, повторяем операцию с третьим и так далее. 5. Продолжаем последовательно подниматься до массива #1(1), где выбираем уже второе слово, вновь опускаемся до конечного «массива» (одно слово), вновь последовательно поднимаемся и опускаемся; возвратившись в массив #1(1), берем третье слово и так далее. 6. Проверив все слова из массива #1(1), возвращаемся в исходную базу, берем 2 слово, получаем массив #1(2) и работаем с ним аналогично. Перевод в десятичную СС – это просто сокращение записи. Можно назначить буквам «вес», например 1-33 и начать искать слагаемые под сумму 33*(33+1)/2 = 561, но т.к. они разнятся всего на единицу, ложных вариантов будет как минимум 90%. Можно назначить первой букве вес 10^-16, 17-ой – 1, последней – 10^16. В промежутке известно что. Ложные варианты сократятся на порядок. 10 можно заменить и на 100, и на 1000, но я не уверен, будет ли алгоритм подбора слагаемых под сумму корректно обрабатывать такие данные. По сути, от двоичного кодирования, как и от дальнейших преобразований, можно отказаться и работать напрямую с буквами. Не говоря уже о возможности существования варианта, где для сравнения 2-х слов на наличие одинаковых букв достаточно, 2-х ячеек, в которых, собственно, и записаны эти слова. Еще нашел макросы на расположение букв в слове в алфавитном порядке. Модернизированную таким образом базу можно отсортировать в алфавитном порядке, имеем, таким образом, 33 группы. Далее можно сгруппировать слова по наличию сочетаний АБ – ЮЯ (528), АБВ – ЭЮЯ (5456), АБВГ – ЫЭЯЮ (40920) и т.д. (исходя из формулы N!/((N – M*K)!*((K!)^M)), и уже это использовать как условие для запрета совмещения тех или иных слов. Если все гораздо проще, то да простит меня Оккам!

Решение задачи: «В поисках панграмм [excel, vba]»

textual
Листинг программы
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

ИИ поможет Вам:


  • решить любую задачу по программированию
  • объяснить код
  • расставить комментарии в коде
  • и т.д
Попробуйте бесплатно

Оцени полезность:

9   голосов , оценка 4.111 из 5