Any suggestions on speeding this code up? - excel

Question

Ok, I have the code below, which takes 18 different words, all in Column A rows 1 to 18, and tries them in all different combos to find a seven word palindrome. I am pretty sure the code will get it done, but it just searches for a LONG time. I know there's a way to check the first and last letters of the combos, to make sure they're the same, before the code runs them through the REVERSE function, I just can't figure out how to do it. I am very new to this.In other words, each time it puts together 7 of the words, if it didn't have to go through the REVERSE function, a ton of time would be saved, and verification that the first and last letters match would do that. Thanks in advance for any help
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

Try, This results in 104,976 which takes less than 2 seconds.
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
Data image
Result Image
If each cell has more than 2 characters, you can do as follows.
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
Case 2 Data
Case 2 Result