[分享]浅谈DICTIONARY(字典)对象

northwolves

应用实例6 (不重复值提取):

Sub Usage6()'以下代码将A：N列的所有文本，数字不重复的复制到O列：

Dim r As Range, c As Range
Set r = Sheets("sheet1").[a:n].SpecialCells(xlCellTypeConstants, 23)
With CreateObject("scripting.dictionary")

For Each c In r
If Not .exists(c.Value) Then .Add c.Value, ""
Next
Sheets("sheet1").[o1].Resize(.Count, 1) = WorksheetFunction.Transpose(.keys)
End With
End Sub

Sub Usage6_2()'跨表不重复值提取,将表All的D列数据提取到表temp的A列
Application.ScreenUpdating = False
Dim r As Range, arr
Worksheets("All").Select
With CreateObject("scripting.dictionary")
For Each r In Range("D3:D" & Range("A65536").End(xlUp).Row)
If Not .exists(r.Value) Then .Add r.Value, Nothing
Next
Worksheets("temp").Select
Cells.Clear
Range("a2").Resize(.Count, 1) = WorksheetFunction.Transpose(.keys)
End With
Application.ScreenUpdating = True
End Sub

应用实例7 (COMBOBOX赋值):

Private Sub UserForm_Initialize()
Dim dic As Object, i As Long, arr
Set dic = CreateObject("Scripting.Dictionary")
For i = 1 To 1000
dic.Add i, ""
Next
UserForm1.ComboBox1.List = dic.keys
Set dic = Nothing
End Sub

northwolves

'应用实例8 (字符频率统计):

'本例统计圆周率前500位中各数字出现的频率并显示在WORKSHEET的前两行
Sub Usage8()
Const pi As String = "3.14159265358979323846264338327950288419716939937510582097494459230781640628620899862803482534211706798214808651328230664709384460955058223172535940812848111745028410270193852110555964462294895493038196442881097566593344612847564823378678316527120190914564856692346034861045432664821339360726024914127372458700660631558817488152092096282925409171536436789259036001133053054882046652138414695194151160943305727036575959195309218611738193261179310511854807446237996274956735188575272489122793818301194912"
Dim i As Long, temp As String, dic As Object
Set dic = CreateObject("scripting.dictionary")
For i = 3 To Len(pi)
temp = Mid(pi, i, 1)
If Not dic.exists(temp) Then
dic.Add temp, 1
Else
dic(temp) = dic(temp) + 1
End If
Next
[a1:a2] = WorksheetFunction.Transpose(Array("Number", "出现次数"))
[b1].Resize(1, dic.Count) = dic.keys
[b2].Resize(1, dic.Count) = dic.items
Set dic = Nothing
End Sub

 

'本例统计某字符串中各字符出现的频率并显示在WORKSHEET的前两行

Sub Usage8_2()
Const s As String = "在VBA中有一个数据字典即dictionary功能很好，运行速度比较快，掌握以后可以替代一些其他查找功能，现向老师请教数据字典即dictionary的基本原理是怎样的，它适合于哪些情况之下可以运用，在运用过程中应当注意哪些问题。"
Dim i As Long, temp As String, dic As Object
Set dic = CreateObject("scripting.dictionary")
For i = 1 To Len(s)
temp = Mid(s, i, 1)
If Not dic.exists(temp) Then
dic.Add temp, 1
Else
dic(temp) = dic(temp) + 1
End If
Next
[a1:a2] = WorksheetFunction.Transpose(Array("字符", "出现次数"))
[b1].Resize(1, dic.Count) = dic.keys
[b2].Resize(1, dic.Count) = dic.items
Set dic = Nothing
End Sub

这个功能比较有用,通过数组的赋值,可以对工作表的某几列进行类似的统计.

练习题:

1.试编码统计1-100000000范围内分别以1-99开始的数字的频率

2.下载一个双色球彩票历史数据,统计一段时间内前十个出现最多的四个号码的组合

northwolves

应用实例9 列出一个工作簿中所有已使用的自定义函数

需要添加对VB项目的信任

Sub UDFSOFACTIVEWORKBOOK()

Dim sh As Worksheet, r As Range, dic As Object, i As Long, temp As String, VBcomp, s() As String, UDF As String

For i = 1 To ActiveWorkbook.VBProject.VBComponents.Count

Set VBcomp = ActiveWorkbook.VBProject.VBComponents(i)

If VBcomp.Type = 1 Then temp = temp & VBCrLf & VBcomp.CodeModule.Lines(1, 65536)

Next

s = Split(temp, VBCrLf)

temp = ""

For i = 0 To UBound(s)

If s(i) Like "Function * As *" Then temp = temp & "@" & "=" & Trim(Split(Split(s(i), "(")(0), "Function")(1)) & "(" '--->All functions with or without parameters

Next

Set dic = CreateObject("scripting.dictionary")

For Each sh In Sheets

For Each r In sh.UsedRange

If r.HasFormula Then

If InStr(temp, "@" & Split(r.Formula, "(")(0)) > 0 Then

UDF = r.Formula & "udf"

Else

UDF = ""

End If

If Not dic.exists(r.Formula) Then dic.Add r.Formula, UDF

End If

Next

Next

Debug.Print "All functions used in activesheet" & VBCrLf & String(50, "-") & VBCrLf & Join(dic.keys, VBCrLf) & VBCrLf & VBCrLf '列出一个工作簿中所有函数

Debug.Print "All user define functions used in activesheet" & VBCrLf & String(50, "-") & VBCrLf & Replace(Join(Filter(dic.items, "udf"), VBCrLf), "udf", "") '列出一个工作簿中所有已使用的自定义函数

Set dic = Nothing

End Sub

应用实例10 列出Word 文档中所用的全部字体集合(在WORD VBA中使用)

Sub Usage10()

Dim myRange As Range, str_Result As String, str_Temp

With CreateObject("scripting.dictionary")

   On Error Resume Next

   For Each str_Temp In Application.FontNames

      Set myRange = ActiveDocument.Content

      With myRange.Find

         .ClearFormatting

         .Font.NameFarEast = str_Temp

         If .Font.NameFarEast <> "" Then

            If .Execute(findtext:="*", MatchWildcards:=True, Wrap:=wdFindStop, Format:=True) Then

            .AddComment str_Temp, ""

            End If

         End If

      End With

   Next

MsgBox Join(.keys, vbCrLf)

End With

End Sub

northwolves

应用实例11 获取中文的拼音字母
Function pinyin(ByVal mystr As String, Optional types As Byte = 0) As String
Dim temp   As String, i As Long, j As Long, a, b
With CreateObject("Scripting.Dictionary")
  .Add "a", "-20319"
  .Add "ai", "-20317"
  .Add "an", "-20304"
  .Add "ang", "-20295"
  .Add "ao", "-20292"
  .Add "ba", "-20283"
  .Add "bai", "-20265"
  .Add "ban", "-20257"
  .Add "bang", "-20242"
  .Add "bao", "-20230"
  .Add "bei", "-20051"
  .Add "ben", "-20036"
  .Add "beng", "-20032"
  .Add "bi", "-20026"
  .Add "bian", "-20002"
  .Add "biao", "-19990"
  .Add "bie", "-19986"
  .Add "bin", "-19982"
  .Add "bing", "-19976"
  .Add "bo", "-19805"
  .Add "bu", "-19784"
  .Add "ca", "-19775"
  .Add "cai", "-19774"
  .Add "can", "-19763"
  .Add "cang", "-19756"
  .Add "cao", "-19751"
  .Add "ce", "-19746"
  .Add "ceng", "-19741"
  .Add "cha", "-19739"
  .Add "chai", "-19728"
  .Add "chan", "-19725"
  .Add "chang", "-19715"
  .Add "chao", "-19540"
  .Add "che", "-19531"
  .Add "chen", "-19525"
  .Add "cheng", "-19515"
  .Add "chi", "-19500"
  .Add "chong", "-19484"
  .Add "chou", "-19479"
  .Add "chu", "-19467"
  .Add "chuai", "-19289"
  .Add "chuan", "-19288"
  .Add "chuang", "-19281"
  .Add "chui", "-19275"
  .Add "chun", "-19270"
  .Add "chuo", "-19263"
  .Add "ci", "-19261"
  .Add "cong", "-19249"
  .Add "cou", "-19243"
  .Add "cu", "-19242"
  .Add "cuan", "-19238"
  .Add "cui", "-19235"
  .Add "cun", "-19227"
  .Add "cuo", "-19224"
  .Add "da", "-19218"
  .Add "dai", "-19212"
  .Add "dan", "-19038"
  .Add "dang", "-19023"
  .Add "dao", "-19018"
  .Add "de", "-19006"
  .Add "deng", "-19003"
  .Add "di", "-18996"
  .Add "dian", "-18977"
  .Add "diao", "-18961"
  .Add "die", "-18952"
  .Add "ding", "-18783"
  .Add "diu", "-18774"
  .Add "dong", "-18773"
  .Add "dou", "-18763"
  .Add "du", "-18756"
  .Add "duan", "-18741"
  .Add "dui", "-18735"
  .Add "dun", "-18731"
  .Add "duo", "-18722"
  .Add "e", "-18710"
  .Add "en", "-18697"
  .Add "er", "-18696"
  .Add "fa", "-18526"
  .Add "fan", "-18518"
  .Add "fang", "-18501"
  .Add "fei", "-18490"
  .Add "fen", "-18478"
  .Add "feng", "-18463"
  .Add "fo", "-18448"
  .Add "fou", "-18447"
  .Add "fu", "-18446"
  .Add "ga", "-18239"
  .Add "gai", "-18237"
  .Add "gan", "-18231"
  .Add "gang", "-18220"
  .Add "gao", "-18211"
  .Add "ge", "-18201"
  .Add "gei", "-18184"
  .Add "gen", "-18183"
  .Add "geng", "-18181"
  .Add "gong", "-18012"
  .Add "gou", "-17997"
  .Add "gu", "-17988"
  .Add "gua", "-17970"
  .Add "guai", "-17964"
  .Add "guan", "-17961"
  .Add "guang", "-17950"
  .Add "gui", "-17947"
  .Add "gun", "-17931"
  .Add "guo", "-17928"
  .Add "ha", "-17922"
  .Add "hai", "-17759"
  .Add "han", "-17752"
  .Add "hang", "-17733"
  .Add "hao", "-17730"
  .Add "he", "-17721"
  .Add "hei", "-17703"
  .Add "hen", "-17701"
  .Add "heng", "-17697"
  .Add "hong", "-17692"
  .Add "hou", "-17683"
  .Add "hu", "-17676"
  .Add "hua", "-17496"
  .Add "huai", "-17487"
  .Add "huan", "-17482"
  .Add "huang", "-17468"
  .Add "hui", "-17454"
  .Add "hun", "-17433"
  .Add "huo", "-17427"
  .Add "ji", "-17417"
  .Add "jia", "-17202"
  .Add "jian", "-17185"
  .Add "jiang", "-16983"
  .Add "jiao", "-16970"
  .Add "jie", "-16942"
  .Add "jin", "-16915"
  .Add "jing", "-16733"
  .Add "jiong", "-16708"
  .Add "jiu", "-16706"
  .Add "ju", "-16689"
  .Add "juan", "-16664"
  .Add "jue", "-16657"
  .Add "jun", "-16647"
  .Add "ka", "-16474"
  .Add "kai", "-16470"
  .Add "kan", "-16465"
  .Add "kang", "-16459"
  .Add "kao", "-16452"
  .Add "ke", "-16448"
  .Add "ken", "-16433"
  .Add "keng", "-16429"
  .Add "kong", "-16427"
  .Add "kou", "-16423"
  .Add "ku", "-16419"
  .Add "kua", "-16412"
  .Add "kuai", "-16407"
  .Add "kuan", "-16403"
  .Add "kuang", "-16401"
  .Add "kui", "-16393"
  .Add "kun", "-16220"
  .Add "kuo", "-16216"
  .Add "la", "-16212"
  .Add "lai", "-16205"
  .Add "lan", "-16202"
  .Add "lang", "-16187"
  .Add "lao", "-16180"
  .Add "le", "-16171"
  .Add "lei", "-16169"
  .Add "leng", "-16158"
  .Add "li", "-16155"
  .Add "lia", "-15959"
  .Add "lian", "-15958"
  .Add "liang", "-15944"
  .Add "liao", "-15933"
  .Add "lie", "-15920"
  .Add "lin", "-15915"
  .Add "ling", "-15903"
  .Add "liu", "-15889"
  .Add "long", "-15878"
  .Add "lou", "-15707"
  .Add "lu", "-15701"
  .Add "lv", "-15681"
  .Add "luan", "-15667"
  .Add "lue", "-15661"
  .Add "lun", "-15659"
  .Add "luo", "-15652"
  .Add "ma", "-15640"
  .Add "mai", "-15631"
  .Add "man", "-15625"
  .Add "mang", "-15454"
  .Add "mao", "-15448"
  .Add "me", "-15436"
  .Add "mei", "-15435"
  .Add "men", "-15419"
  .Add "meng", "-15416"
  .Add "mi", "-15408"
  .Add "mian", "-15394"
  .Add "miao", "-15385"
  .Add "mie", "-15377"
  .Add "min", "-15375"
  .Add "ming", "-15369"
  .Add "miu", "-15363"
  .Add "mo", "-15362"
  .Add "mou", "-15183"
  .Add "mu", "-15180"
  .Add "na", "-15165"
  .Add "nai", "-15158"
  .Add "nan", "-15153"
  .Add "nang", "-15150"
  .Add "nao", "-15149"
  .Add "ne", "-15144"
  .Add "nei", "-15143"
  .Add "nen", "-15141"
  .Add "neng", "-15140"
  .Add "ni", "-15139"
  .Add "nian", "-15128"
  .Add "niang", "-15121"
  .Add "niao", "-15119"
  .Add "nie", "-15117"
  .Add "nin", "-15110"
  .Add "ning", "-15109"
  .Add "niu", "-14941"
  .Add "nong", "-14937"
  .Add "nu", "-14933"
  .Add "nv", "-14930"
  .Add "nuan", "-14929"
  .Add "nue", "-14928"
  .Add "nuo", "-14926"
  .Add "o", "-14922"
  .Add "ou", "-14921"
  .Add "pa", "-14914"
  .Add "pai", "-14908"
  .Add "pan", "-14902"
  .Add "pang", "-14894"
  .Add "pao", "-14889"
  .Add "pei", "-14882"
  .Add "pen", "-14873"
  .Add "peng", "-14871"
  .Add "pi", "-14857"
  .Add "pian", "-14678"
  .Add "piao", "-14674"
  .Add "pie", "-14670"
  .Add "pin", "-14668"
  .Add "ping", "-14663"
  .Add "po", "-14654"
  .Add "pu", "-14645"
  .Add "qi", "-14630"
  .Add "qia", "-14594"
  .Add "qian", "-14429"
  .Add "qiang", "-14407"
  .Add "qiao", "-14399"
  .Add "qie", "-14384"
  .Add "qin", "-14379"
  .Add "qing", "-14368"
  .Add "qiong", "-14355"
  .Add "qiu", "-14353"
  .Add "qu", "-14345"
  .Add "quan", "-14170"
  .Add "que", "-14159"
  .Add "qun", "-14151"
  .Add "ran", "-14149"
  .Add "rang", "-14145"
  .Add "rao", "-14140"
  .Add "re", "-14137"
  .Add "ren", "-14135"
  .Add "reng", "-14125"
  .Add "ri", "-14123"
  .Add "rong", "-14122"
  .Add "rou", "-14112"
  .Add "ru", "-14109"
  .Add "ruan", "-14099"
  .Add "rui", "-14097"
  .Add "run", "-14094"
  .Add "ruo", "-14092"
  .Add "sa", "-14090"
  .Add "sai", "-14087"
  .Add "san", "-14083"
  .Add "sang", "-13917"
  .Add "sao", "-13914"
  .Add "se", "-13910"
  .Add "sen", "-13907"
  .Add "seng", "-13906"
  .Add "sha", "-13905"
  .Add "shai", "-13896"
  .Add "shan", "-13894"
  .Add "shang", "-13878"
  .Add "shao", "-13870"
  .Add "she", "-13859"
  .Add "shen", "-13847"
  .Add "sheng", "-13831"
  .Add "shi", "-13658"
  .Add "shou", "-13611"
  .Add "shu", "-13601"
  .Add "shua", "-13406"
  .Add "shuai", "-13404"
  .Add "shuan", "-13400"
  .Add "shuang", "-13398"
  .Add "shui", "-13395"
  .Add "shun", "-13391"
  .Add "shuo", "-13387"
  .Add "si", "-13383"
  .Add "song", "-13367"
  .Add "sou", "-13359"
  .Add "su", "-13356"
  .Add "suan", "-13343"
  .Add "sui", "-13340"
  .Add "sun", "-13329"
  .Add "suo", "-13326"
  .Add "ta", "-13318"
  .Add "tai", "-13147"
  .Add "tan", "-13138"
  .Add "tang", "-13120"
  .Add "tao", "-13107"
  .Add "te", "-13096"
  .Add "teng", "-13095"
  .Add "ti", "-13091"
  .Add "tian", "-13076"
  .Add "tiao", "-13068"
  .Add "tie", "-13063"
  .Add "ting", "-13060"
  .Add "tong", "-12888"
  .Add "tou", "-12875"
  .Add "tu", "-12871"
  .Add "tuan", "-12860"
  .Add "tui", "-12858"
  .Add "tun", "-12852"
  .Add "tuo", "-12849"
  .Add "wa", "-12838"
  .Add "wai", "-12831"
  .Add "wan", "-12829"
  .Add "wang", "-12812"
  .Add "wei", "-12802"
  .Add "wen", "-12607"
  .Add "weng", "-12597"
  .Add "wo", "-12594"
  .Add "wu", "-12585"
  .Add "xi", "-12556"
  .Add "xia", "-12359"
  .Add "xian", "-12346"
  .Add "xiang", "-12320"
  .Add "xiao", "-12300"
  .Add "xie", "-12120"
  .Add "xin", "-12099"
  .Add "xing", "-12089"
  .Add "xiong", "-12074"
  .Add "xiu", "-12067"
  .Add "xu", "-12058"
  .Add "xuan", "-12039"
  .Add "xue", "-11867"
  .Add "xun", "-11861"
  .Add "ya", "-11847"
  .Add "yan", "-11831"
  .Add "yang", "-11798"
  .Add "yao", "-11781"
  .Add "ye", "-11604"
  .Add "yi", "-11589"
  .Add "yin", "-11536"
  .Add "ying", "-11358"
  .Add "yo", "-11340"
  .Add "yong", "-11339"
  .Add "you", "-11324"
  .Add "yu", "-11303"
  .Add "yuan", "-11097"
  .Add "yue", "-11077"
  .Add "yun", "-11067"
  .Add "za", "-11055"
  .Add "zai", "-11052"
  .Add "zan", "-11045"
  .Add "zang", "-11041"
  .Add "zao", "-11038"
  .Add "ze", "-11024"
  .Add "zei", "-11020"
  .Add "zen", "-11019"
  .Add "zeng", "-11018"
  .Add "zha", "-11014"
  .Add "zhai", "-10838"
  .Add "zhan", "-10832"
  .Add "zhang", "-10815"
  .Add "zhao", "-10800"
  .Add "zhe", "-10790"
  .Add "zhen", "-10780"
  .Add "zheng", "-10764"
  .Add "zhi", "-10587"
  .Add "zhong", "-10544"
  .Add "zhou", "-10533"
  .Add "zhu", "-10519"
  .Add "zhua", "-10331"
  .Add "zhuai", "-10329"
  .Add "zhuan", "-10328"
  .Add "zhuang", "-10322"
  .Add "zhui", "-10315"
  .Add "zhun", "-10309"
  .Add "zhuo", "-10307"
  .Add "zi", "-10296"
  .Add "zong", "-10281"
  .Add "zou", "-10274"
  .Add "zu", "-10270"
  .Add "zuan", "-10262"
  .Add "zui", "-10260"
  .Add "zun", "-10256"
  .Add "zuo", "-10254"
  a = .Keys
  b = .Items
  End With
For i = 1 To Len(mystr)
For j = UBound(a) - 1 To 0 Step -1
If Val(b(j)) <= Asc(Mid(mystr, i, 1)) Then Exit For
Next
temp = temp & IIf(types, UCase(Left(a(j), 1)), " " & a(j))
Next

pinyin = Trim(temp)
End Function

Sub xxx()
Const s As String = "中华人民共和国"
MsgBox s & vbCrLf & pinyin(s) & vbCrLf & pinyin(s, 1)
End Sub

northwolves

以下是一些连接,供参考:

http://www.google.cn/search?q=oobird+dictionary&num=100&complete=1&hl=zh-CN&newwindow=1&filter=0

http://www.google.cn/search?q=northwolves+dictionary&num=100&complete=1&hl=zh-CN&newwindow=1&filter=0

http://www.google.cn/search?q=jindon+dictionary&num=100&complete=1&hl=zh-CN&newwindow=1&filter=0

山菊花

谢狼版主辛勤奉献，讲得全面细致，很好。

northwolves

应用实例12 24点

参考http://northwolves.blog.excelhome.net/user1/northwolves/archives/2006/544.html改写,原来使用的是集合,可以看到,效率提高很多

Sub get24p()
Const p24 = "123412431324134214231432213421432314234124132431312431423214324134123421412341324213423143124321"
Dim A As Integer, B As Integer, C As Integer, D As Integer, temp As String, i As Integer, Answer As Object, K As Integer, s() As String, x
Randomize '随机种子初始化
temp = InputBox("请顺序输入四个整数,空格隔开", "提示", Int(Rnd * 10 + 1) & " " & Int(Rnd * 10 + 1) & " " & Int(Rnd * 10 + 1) & " " & Int(Rnd * 10 + 1))
s = Split(temp)
Set Answer = CreateObject("scripting.dictionary") '创建字典对象
On Error Resume Next '忽略错误
For i = 0 To 23 '列举各种情形的全部排列,添加到字典对象中
A = s(Mid(p24, i * 4 + 1, 1) - 1)
B = s(Mid(p24, i * 4 + 2, 1) - 1)
C = s(Mid(p24, i * 4 + 3, 1) - 1)
D = s(Mid(p24, i * 4 + 4, 1) - 1)
If A <= B And B <= C And C <= D Then Answer.Add A & "+" & B & "+" & C & "+" & D & "=24", ""
If B <= C Then Answer.Add A & "+(" & B & "+" & C & ")/" & D & "=24", ""
If A <= B Then Answer.Add A & "+" & B & "+" & C & "-" & D & "=24", ""
If B > C / D Then Answer.Add A & "/(" & B & "-" & C & "/" & D & ")" & "=24", ""
If C <= D Then Answer.Add A & "/" & B & "+" & C & "+" & D & "=24", ""
If B <= C Then Answer.Add A & "*(" & B & "+" & C & "/" & D & ")" & "=24", ""
If B <= C Then Answer.Add A & "*(" & B & "+" & C & ")+" & D & "=24", ""
If B <= C Then Answer.Add A & "*(" & B & "+" & C & ")-" & D & "=24", ""
If C <= D Then Answer.Add A & "*" & B & "+" & C & "+" & D & "=24", ""
If A <= B And C <= D Then Answer.Add A & "*" & B & "+" & C & "*" & D & "=24", ""
If A <= B Then Answer.Add A & "*" & B & "+" & C & "-" & D & "=24", ""
If A <= B Then Answer.Add A & "*" & B & "/" & C & "+" & D & "=24", ""
If A <= B And C <= D Then Answer.Add A & "*" & B & "/" & C & "/" & D & "=24", ""
If A <= B Then Answer.Add A & "*" & B & "/" & C & "-" & D & "=24", ""
If A <= B And B <= C Then Answer.Add A & "*" & B & "*" & C & "+" & D & "=24", ""
If A <= B And B <= C Then Answer.Add A & "*" & B & "*" & C & "/" & D & "=24", ""
If A <= B And B <= C And C <= D Then Answer.Add A & "*" & B & "*" & C & "*" & D & "=24", ""
If A <= B And B <= C Then Answer.Add A & "*" & B & "*" & C & "-" & D & "=24", ""
If A <= B And C <= D Then Answer.Add A & "*" & B & "-" & C & "*" & D & "=24", ""
If A <= B And B <= C Then Answer.Add "(" & A & "+" & B & "+" & C & ")/" & D & "=24", ""
If A <= B And B <= C Then Answer.Add "(" & A & "+" & B & "+" & C & ")*" & D & "=24", ""
If A <= B And C <= D And A * B <= C * D Then Answer.Add "(" & A & "+" & B & ")*(" & C & "+" & D & ")=24", ""
If A <= B Then Answer.Add "(" & A & "+" & B & ")*(" & C & "-" & D & ")=24", ""
If A <= B Then Answer.Add "(" & A & "+" & B & ")*" & C & "/" & D & "=24", ""
If A <= B And C <= D Then Answer.Add "(" & A & "+" & B & ")*" & C & "*" & D & "=24", ""
If A <= B Then Answer.Add "(" & A & "+" & B & "-" & C & ")*" & D & "=24", ""
If A >= B And C >= D Then Answer.Add "(" & A & "-" & B & ")*(" & C & "-" & D & ")=24", ""
If C <= D Then Answer.Add "(" & A & "-" & B & ")*" & C & "*" & D & "=24", ""
Answer.Add "(" & A & "-" & B & "/" & C & ")*" & D & "=24", ""
Answer.Add A & "*(" & B & "-" & C & ")+" & D & "=24", ""
Answer.Add A & "*(" & B & "-" & C & ")-" & D & "=24", ""
Answer.Add "(" & A & "-" & B & ")*" & C & "/" & D & "=24", ""
Next

For Each x In Answer.keys '遍历全部关键字
If Application.Evaluate(x) = True Then Answer(x) = x '如果关键字值为真,将其赋给对应项目
Next
s = Filter(Answer.items, "=") '筛选含有"="的项目
If UBound(s) > -1 Then
MsgBox Trim(Join(s, vbCrLf)), , temp & "--->24" 's不为空(有解),消息框显示全部解
Else
MsgBox "无解", , temp & "--->24" 's为空(无解),消息框显示无解
End If
Set Answer = Nothing
End Sub

Kevin

好文！支持！

[此贴子已经被作者于2007-9-10 11:21:12编辑过]

likangcrmh

先下载再说，回家慢慢消化

hyy514

我前天一看到就收藏了，想不到还有更新，谢谢狼版主，版主辛苦了！