excel - 有关加快此代码的任何建议?
问题描述
好的,我有下面的代码,它包含 18 个不同的单词,都在 A 列的第 1 到 18 行中,并在所有不同的组合中尝试它们以找到一个 7 个单词的回文。我很确定代码会完成它,但它只是搜索了很长时间。我知道有一种方法可以检查组合的第一个和最后一个字母,以确保它们相同,在代码通过 REVERSE 函数运行它们之前,我只是不知道该怎么做。我对此很陌生。换句话说,每次将 7 个单词放在一起,如果不必经过 REVERSE 功能,将节省大量时间,并验证第一个和最后一个字母比赛会这样做。提前感谢您的帮助
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
解决方案
试试看,这会产生 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