Есть предложения по ускорению этого кода?

Question

Хорошо, у меня есть приведенный ниже код, который берет 18 разных слов, все в столбце A, строки с 1 по 18, и пробует их во всех различных комбинациях, чтобы найти палиндром из семи слов. Я почти уверен, что код сделает это, но он просто ищет ДОЛГОЕ время. Я знаю, что есть способ проверить первую и последнюю буквы комбинаций, чтобы убедиться, что они одинаковы, прежде чем код запустит их через функцию REVERSE, я просто не могу понять, как это сделать. Я новичок в этом. Другими словами, каждый раз, когда он складывает вместе 7 слов, если бы не пришлось go через функцию ОБРАТИТЬ, тонна времени была бы сэкономлена, и проверка того, что первая и совпадение последних букв сделает это. Заранее благодарим за любую помощь

 Sub SevenDrome()

Dim count As Integer

count = 0

Dim wordtest As String
Dim wordpal As String

For j = 1 To 18
   For k = 1 To 18
      For l = 1 To 18
         For m = 1 To 18
            For n = 1 To 18
               For o = 1 To 18
                  For p = 1 To 18

wordtest = Cells(j, 1) & Cells(k, 1) & Cells(l, 1) & Cells(m, 1) & Cells(n, 1) & Cells(o, 1) & Cells(p, 1)
wordpal = REVERSE(wordtest)

If wordtest = wordpal Then
count = count + 1

Cells(count, 7) = wordtest

End If
                  Next p
               Next o
            Next n
         Next m
      Next l
   Next k
Next j

End Sub

Answer 1

Попробуйте. Результатом будет 104 976, что займет менее 2 секунд.

Sub test()
    Dim a(1 To 18)
    Dim vR(1 To 1000000, 1 To 1)
    Dim cnt As Long
    Dim i As Integer, k As Integer, l As Integer
    Dim m As Integer, n As Integer, o As Integer

    For i = 1 To 18
        a(i) = Range("a" & i)
    Next i

    For j = 1 To 18
        For k = 1 To 18
            If a(j) = a(k) Then
                For l = 1 To 18
                    For m = 1 To 18
                        If a(l) = a(m) Then
                           For n = 1 To 18
                              For o = 1 To 18
                                If a(n) = a(o) Then
                                    For p = 1 To 18
                                       cnt = cnt + 1
                                       vR(cnt, 1) = a(j) & a(l) & a(n) & a(p) & a(o) & a(m) & a(k)
                                       DoEvents
                                    Next p
                                End If
                              Next o
                           Next n
                        End If
                    Next m
                Next l
            End If
        Next k
    Next j
    Range("g1").Resize(cnt) = vR
End Sub

Изображение данных

Изображение результата

Если в каждой ячейке более 2 символов, вы можете сделать следующее.

Sub test2()
    Dim a(1 To 18)
    Dim vR(1 To 1000000, 1 To 1)
    Dim cnt As Long
    Dim i As Integer, k As Integer, l As Integer
    Dim m As Integer, n As Integer, o As Integer

    For i = 1 To 18
        a(i) = Range("a" & i)
    Next i

    For j = 1 To 18
        For k = 1 To 18
            If a(j) = Reverse(a(k)) Then
                For l = 1 To 18
                    For m = 1 To 18
                        If a(l) = Reverse(a(m)) Then
                           For n = 1 To 18
                              For o = 1 To 18
                                If a(n) = Reverse(a(o)) Then
                                    For p = 1 To 18
                                        If a(p) = Reverse(a(p)) Then
                                            cnt = cnt + 1
                                            vR(cnt, 1) = a(j) & a(l) & a(n) & a(p) & a(o) & a(m) & a(k)
                                            DoEvents
                                        End If
                                    Next p
                                End If
                              Next o
                           Next n
                        End If
                    Next m
                Next l
            End If
        Next k
    Next j
    Range("g1").CurrentRegion.Clear
    If cnt Then
        Range("g1").Resize(cnt) = vR
    End If
End Sub

Function Reverse(s)
    Dim i As Integer
    Dim myS As String
    For i = Len(s) To 1 Step -1
        myS = myS & Mid(s, i, 1)
    Next i
    Reverse = myS

End Function

Данные случая 2

Результат случая 2