【Alphabear 找單字小工具】(非攻略、非破解)
警告：使用本工具可能導致遊戲樂趣喪失！
我從來沒寫過遊戲評測文，介紹遊戲也不是本站主要走向。但是我覺得透過這個alphabear找單字小工具，得以同時體現「效率」與「創意」兩大核心價值，故為文以誌之。
Alphabear是一款手機上的拼字小遊戲，除了單純拼英文單字之外，它還融合了幾個會讓你上癮的元素，例如練功升級、蒐集熊種、講究實力又略帶運氣的玩法……老實說我覺得遊戲平衡度設計的還不錯，就算卡關了，稍微把熊的等級練高就很有機會過關。不過偶有幾次遇到「只差一點點就過關了，但是有些單字就是怎麼也拼不出來」的窘境，於是我就用excel寫了這個找單字小工具。
【功能】
告訴Excel你要找包含哪些字母的單字，程式就會自動列出所有符合條件的單字。例如你場面上可以用的字母有”z”有”a”有”o”，就在輸入欄位打上”zao”，按下確定，即可從清單中挑一個喜歡的單字來用。
【說明】
1.A欄為單字資料庫，目前我隨便放了一個好像是TOEFL還是TOEIC的字庫。使用者可自行擴充。
2.輸入時可不考慮順序。”abc”和”cba”都可以找到所有含有這三個字母的單字。
3.可輸入重複的字母。輸入”a”，會找到所有含有字母a的單字。輸入”aa”則會找到所有含有兩個a以上的單字。輸入”aaa”則會找到所有含有三個a以上的單字。以此類推。
4.必須允許巨集。若您有疑慮，可自行將下列程式碼複製回去修改。
5.受限於電腦運算速度，以及受限於我粗糙的演算法，執行效率可能不盡理想。故不推薦拿來玩90秒的限時關卡。
其實我後來有對這個vba程式進行改版。功能做得更強大、也更人性化，同時也更耗電腦運算資源……不過那個版本存在老婆的電腦裡了。
【程式碼】
Sub 找字母()
'
' 找字母 Macro
'
'
Dim voc(10000) As String
Range("B1:Z9999").Clear
cl = 1
target = InputBox("找哪幾個字母")
cwton = Range("a1:" & "A" & "1").Cells.Count
searchrange = "A" & ":" & "A"
For m = 1 To Len(target)
tg = Mid(target, m, 1)
Columns(cwton + m - 1).Select
Set a = Selection.Find(What:=tg, After:=ActiveCell, LookIn:=xlFormulas, LookAt _
:=xlPart, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:= _
False, MatchByte:=False, SearchFormat:=False)
If Not a Is Nothing Then
a.Activate
Cells(a.Row, cwton + m) = a.Value
x = InStr(1, Cells(a.Row, cwton + m), tg)
y = InStr(1, Cells(a.Row, cwton + m), UCase(tg))
If x > y Then Order = x Else Order = y
tempstr = Mid(Cells(a.Row, cwton + m), 1, Order - 1) & "_" & Mid(Cells(a.Row, cwton + m), Order + 1, Len(Cells(a.Row, cwton + m)) - Order)
Cells(a.Row, cwton + m) = Replace(Cells(a.Row, cwton + m).Value, Cells(a.Row, cwton + m), tempstr)
End If
For i = 1 To Sheet1.UsedRange.Rows.Count
Set a = Selection.FindNext(After:=ActiveCell)
'If Not a Is Nothing Then aa.Activate Else MsgBox ("XX")
If cl = 1 Then
FA = a.Address
If Not a Is Nothing Then
a.Activate
Cells(a.Row, cwton + m) = a.Value
x = InStr(1, Cells(a.Row, cwton + m), tg)
y = InStr(1, Cells(a.Row, cwton + m), UCase(tg))
If x > y Then Order = x Else Order = y
tempstr = Mid(Cells(a.Row, cwton + m), 1, Order - 1) & "_" & Mid(Cells(a.Row, cwton + m), Order + 1, Len(Cells(a.Row, cwton + m)) - Order)
Cells(a.Row, cwton + m) = Replace(Cells(a.Row, cwton + m).Value, Cells(a.Row, cwton + m), tempstr)
End If
Else
If a.Address = FA Then Exit For
If Not a Is Nothing Then
a.Activate
Cells(a.Row, cwton + m) = a.Value
x = InStr(1, Cells(a.Row, cwton + m), tg)
y = InStr(1, Cells(a.Row, cwton + m), UCase(tg))
If x > y Then Order = x Else Order = y
tempstr = Mid(Cells(a.Row, cwton + m), 1, Order - 1) & "_" & Mid(Cells(a.Row, cwton + m), Order + 1, Len(Cells(a.Row, cwton + m)) - Order)
Cells(a.Row, cwton + m) = Replace(Cells(a.Row, cwton + m).Value, Cells(a.Row, cwton + m), tempstr)
End If
End If
cl = cl + 1
Next
cl = 1
mc = m + 1
Next
n = 1
For i = 1 To Sheet1.UsedRange.Rows.Count
If Cells(i, mc) = "" Then
Else
Cells(n, "P") = Cells(i, 1)
n = n + 1
End If
Next
End Sub