猜数字游戏（有待进一步完善，请给点建议）

aoe1981

　　折腾了半晚上，做了这么个东西，先上图：
　　
　　

aoe1981

　　上附件：
　　 数字推理游戏（aoe1981新代码版）.rar (34.58 KB, 下载次数: 44)

2014-11-16 14:31 上传

点击文件名下载附件

　　特点：1.重新编写了代码；
　　　　　2.加入了榜单，该榜单可以排序，始终保持前10名记录（存在问题是对于玩家名的长度在区分半角字符与全角字符上可能做得不够好，也折腾了半天，有点屈服了……）
　　（榜单中数字显示为文本格式的已更新。）
　　（排序也由>改为>=）

aoe1981

代码如下，加入了一些功能，自我感觉代码应该比楼主的精简一些：
工作表代码：

1. Private Sub Worksheet_Change(ByVal Target As Range)
   
2. If Target.Address(0, 0) = "D1" Then
   
3.     If IsNumeric(Target.Value) And Len(Trim(Target.Value)) = 4 Then
   
4.         BiDui Target.Value
   
5.     Else
   
6.         MsgBox "请输入四位不重复数字！", , "友情提示"
   
7.         Application.EnableEvents = False
   
8.         Target.Value = ""
   
9.         Application.EnableEvents = True
   
10.     End If
    
11. End If
    
12. End Sub
    
13. Private Sub Worksheet_SelectionChange(ByVal Target As Range)
    
14. Range("d1").Select
    
15. End Sub

复制代码

模块代码：

1. Option Explicit
   
2. Public sjs$, n%, kj As Boolean
   
3. Public Sub RndShu() '随机数
   
4. Dim arr$(0 To 9), i%, r%, gd$
   
5. n = 0: Range("d1,b3:d12") = "": kj = False '次数归零、区域清空、重新开局
   
6. For i = 0 To 9
   
7.     arr(i) = i
   
8. Next i
   
9. Randomize: sjs = ""
   
10. For i = 0 To 9 '【香川经典数组洗牌法】
    
11.     r = Int(Rnd() * (9 - i)) + i
    
12.     gd = arr(i): arr(i) = arr(r): arr(r) = gd
    
13. Next i
    
14. For i = 0 To 3
    
15.     sjs = sjs & arr(i)
    
16. Next i
    
17. MsgBox "随机数已生成，可以开始。", , "友情提示"
    
18. End Sub
    
19. Public Sub BiDui(srs$) '比对（输入数）
    
20. If sjs = "" Or kj Then MsgBox "请点击开始按钮获取随机数。", , "友情提示": Exit Sub
    
21. Dim i%, j%, brr$(1 To 4), crr$(1 To 4), a%, b%
    
22. For i = 1 To 4
    
23.     brr(i) = Mid(srs, i, 1): crr(i) = Mid(sjs, i, 1)
    
24. Next i
    
25. For i = 1 To 4
    
26.     For j = 1 To 4
    
27.         If i = j And brr(i) = crr(j) Then
    
28.             a = a + 1: Exit For
    
29.         ElseIf brr(i) = crr(j) Then
    
30.             b = b + 1: Exit For
    
31.         End If
    
32.     Next j
    
33. Next i
    
34. n = n + 1
    
35. Range("b" & n + 2).Value = n
    
36. Range("c" & n + 2).Value = srs
    
37. Range("d" & n + 2).Value = a & "A" & b & "B"
    
38. If a = 4 Then BangDan n, sjs Else If n = 10 Then MsgBox "失败！不要气馁，点击开始，再来一次！", , "友情提示": kj = True
    
39. End Sub
    
40. Public Sub BangDan(cs%, sz$) '榜单（次数、数字）
    
41. Dim drr, wj$, i%, j%, h%, l%, gd, m%
    
42. drr = Range("o2:q13").Value
    
43. kj = True
    
44. wj = Application.InputBox("胜出，您真厉害！" & Chr(10) & "请输入您的大名（最长10个字符），看看能否刷新榜单！" & Chr(10), "输入姓名", _
    
45. Choose(Int(Rnd() * 4 + 1), "英雄", "无敌", "独孤", "智圣"), , , , , 2)
    
46. m = WorksheetFunction.Max(10 - Len(wj), 0)
    
47. wj = Mid(wj & WorksheetFunction.Rept(" ", m), 1, 10)
    
48. drr(UBound(drr), 1) = wj: drr(UBound(drr), 2) = cs: drr(UBound(drr), 3) = sz '记录在最末尾
    
49. h = UBound(drr): l = UBound(drr, 2)
    
50. For i = 2 To h '特殊处理榜单中的空值，使其排序后不在最前面
    
51.     If drr(i, 2) = "" Then drr(i, 2) = 11
    
52. Next i
    
53. For i = 2 To h - 1 '排序
    
54.     For j = i + 1 To h
    
55.         If drr(i, 2) > drr(j, 2) Then
    
56.             gd = drr(i, 1): drr(i, 1) = drr(j, 1): drr(j, 1) = gd
    
57.             gd = drr(i, 2): drr(i, 2) = drr(j, 2): drr(j, 2) = gd
    
58.             gd = drr(i, 3): drr(i, 3) = drr(j, 3): drr(j, 3) = gd
    
59.         End If
    
60.     Next j
    
61. Next i
    
62. For i = 2 To h
    
63.     If drr(i, 2) = 11 Then drr(i, 2) = ""
    
64. Next i
    
65. Range("o2").Resize(h - 1, l).Value = drr
    
66. End Sub
    
67. Public Sub ShuoMing() '说明
    
68. MsgBox "1.点击开始按钮获取随机数，通过最多10次的输入测试，推测该随机数，推测准确的获胜并进入榜单；" & Chr(10) & Chr(10) _
    
69. & "2.在D1单元格输入0-9四位不重复的数字,敲击回车开始验证,在D3:D12区域记录验证结果为形如：xAyB；" & Chr(10) & Chr(10) _
    
70. & "3.xA表示输入数字与随机数的数位相同且数字相同的有x个，yB表示数位不同但数字相同的有y个。" & Chr(10) & Chr(10) _
    
71. & "4.系统每次随机产生一个不重复随机四位数，千位也可出现0，在每局游戏中，该随机数保持不变。", , "游戏说明"
    
72. End Sub
    
73. Public Sub ChaKan() '查看
    
74. Dim err, i%, j%, xx$, yy$
    
75. err = Range("o2:q12").Value
    
76. For i = 1 To UBound(err)
    
77.     For j = 1 To UBound(err, 2)
    
78.         xx = xx & "　　" & err(i, j)
    
79.     Next j
    
80.     yy = yy & Mid(xx, 2) & Chr(10): xx = ""
    
81. Next i
    
82. MsgBox yy, , "榜单"
    
83. End Sub
    

复制代码

aoe1981

主要的特点是：关于随机不重复数字的四位数的产生，利用了香川经典数组洗牌法的原理，可能是精简的一个原因吧……
希望大家、尤其是楼主，进一步指点下……

aoe1981

　　修改了用词上的不准确的部分，附件已同步更新：
　　

liulang0808

aoe1981 发表于 2014-11-16 00:21
主要的特点是：关于随机不重复数字的四位数的产生，利用了香川经典数组洗牌法的原理，可能是精简的一个原因 ...

改进很大，现在才像个游戏。。。。

aoe1981

　　所谓“榜单”数据其实是寄存在工作表下列区域的，呵呵：


　　现在的问题是，如何在有全角、半角的情况下将榜单姓名对齐，超长姓名截取，不足补齐，只是全半角麻烦呀：

liulang0808

aoe1981 发表于 2014-11-16 08:55
　　所谓“榜单”数据其实是寄存在工作表下列区域的，呵呵：

存在汉字与非汉字的问题，所以处理起来比较麻烦的

aoe1981

　　很费事，又做了一个7步的，感觉中间部分还是有点凑巧，不完全是推理得到的结果：
　　

aoe1981

　　竟是半天摸索不来这个推理的规律，感觉可能很多，运气好的会走到最大可能上，这个所有可能方案，应该是组成了一棵树，最长的那枝就是通向结果的吧……
　　我通常都是先输入：0123、1234，再接下来便有点乱了，一时总结不出规律了……