用VBA制作的舒尔特格子

zxc1zxc1zxc1

在学习VBA的时候，尝试着做一些简单益智的小游戏，也是挺有意思的。
如果各位网友有一些有意思的作品，希望可以分享一下，大家一起欣赏与学习。
--------------------------------------------------------------------------------------------------------
各位，不好意思，之前上传的工作表，删掉了一张表，而代码里工作表是通过索引号引用的，所以导致400报错。
8月13日11：50重新上传。谢谢各位发现问题。

ardu95

提示错误  400

sirsunny

玩不了，提示如图：

zxc1zxc1zxc1

ardu95 发表于 2019-8-13 06:12
提示错误  400

已重新上传文件，应该可以使用了。

zxc1zxc1zxc1

sirsunny 发表于 2019-8-13 10:11
玩不了，提示如图：

已修改，重新下载试试，应该好用了。

YZC51

谢谢楼主分享！！！

YZC51

简介
以 7—12 岁年龄组为例，能达到26"以上为优秀，
舒尔特方格
学习成绩应是名列前茅， 42"属于中等水平，班级排名会在中游或偏下， 50"则问题较大，考试会出现不及格现象。
以 12―14 岁年龄组为例，能到达 16 "以上为优良，学习成就应是名列前茅， 26 "属于中等水平，班级排名会在中游或偏下， 36 "则问题较大，测验会呈现不合格现象。
18 岁及以上成年人最好可到达 8 "的程度， 20 "为中等程度。
“舒尔特方格”不但可以简单测量注意力水平，而且是很好的训练方法。又是心理咨询师进行心理治疗时常用的基本方法。
舒尔特表可以通过动态的练习锻炼视神经末梢。心理学上用此表来研究和发展心理感知的速度，其中包括视觉定向搜索运动的速度。

stone3772

能否分享代码密码呀，想学习。

powerremain

运行一次后，textbox中的数字无法调节，需要重新打开

zxc1zxc1zxc1

stone3772 发表于 2019-12-12 10:35
能否分享代码密码呀，想学习。

Option Explicit
Public Y As Variant, t As Single, mycolor1 As Integer, mycolor2 As Integer, mycolor3 As Integer
'mycolor1, mycolor2分别为字体和背景颜色
Public Declare Function PlaySound Lib "winmm.dll" Alias "PlaySoundA" (ByVal lpszName As String, ByVal hModule As Long, ByVal dwFlags As Long) As Long
'调用系统声音


Sub 自动生成舒尔特()
Dim myrow As Integer, myrange As Range, mynumber As Integer, sht As Worksheet
Set sht = Sheets(2)
If OptionButton1.Value = True Then
    mycolor1 = 3 '红字
    mycolor2 = 6 '黄底
Else
    mycolor1 = 2 '黑底
    mycolor2 = 1 '白字
End If
If OptionButton3.Value = True Then
    mycolor3 = mycolor2
Else
    mycolor3 = mycolor1
End If
myrow = TextBox1.Value
Set myrange = Range(sht.Cells(2, 2), sht.Cells(2 + myrow - 1, 2 + myrow - 1))
Cells.Select
Selection.Clear
Selection.Interior.ColorIndex = 16
mynumber = myrow ^ 2
'For i = 2 To myrow + 1
  'For j = 2 To myrow + 1
'kkk:
  'Randomize
  'X = Int(Rnd * mynumber) + 1
  'If Application.CountIf(myrange, X) = 0 Then
  'Cells(i, j) = X
  'Else
  'GoTo kkk
  'End If
  'Next j
'Next i '以上循环简单却效率低下,改成下面的不放回随机抽样算法
Dim myarr() As Integer
ReDim myarr(1 To mynumber)
For i = 1 To mynumber
myarr(i) = i
Next
For j = 1 To mynumber
Randomize
s = Int(Rnd * (mynumber - j)) + 1
w = myarr(s)
myarr(s) = myarr(j)
myarr(j) = w
Next
For p = 2 To myrow + 1
  For q = 2 To myrow + 1
  Cells(p, q) = myarr((p - 2) * myrow + q - 1)
  Next
Next
myrange.Select
With Selection
      .ColumnWidth = 11 * 5 / myrow
      .RowHeight = 70 * 5 / myrow
      .Font.Name = "宋体"
      .Font.Size = 36 * 5 / myrow
      .Font.Bold = True
      .Font.ColorIndex = mycolor1
      .HorizontalAlignment = xlCenter
      .Interior.ColorIndex = mycolor2
End With
Selection.NumberFormatLocal = "G/通用格式"
    With Selection.Borders(xlEdgeLeft)
        .ColorIndex = 36
        .Weight = xlThick
        .LineStyle = xlDouble
    End With
    With Selection.Borders(xlEdgeTop)
        .ColorIndex = 36
        .Weight = xlThick
        .LineStyle = xlDouble
    End With
    With Selection.Borders(xlEdgeBottom)
        .ColorIndex = 36
        .Weight = xlThick
        .LineStyle = xlDouble
    End With
    With Selection.Borders(xlEdgeRight)
        .ColorIndex = 36
        .Weight = xlThick
        .LineStyle = xlDouble
    End With
    With Selection.Borders(xlInsideVertical)
        .ColorIndex = 36
        .Weight = xlThick
        .LineStyle = xlDouble
    End With
    With Selection.Borders(xlInsideHorizontal)
        .ColorIndex = 36
        .Weight = xlThick
        .LineStyle = xlDouble
    End With
Range("A20").Select
Y = 1
TextBox2.Text = 1
t = Timer
End Sub

Private Sub CommandButton1_Click()
Call 自动生成舒尔特
End Sub

Private Sub ComboBox1_Change()

End Sub

Private Sub OptionButton2_Click()

End Sub

Private Sub SpinButton1_SpinUp()
If TextBox1.Text = 9 Then
TextBox1.Text = TextBox1.Text
Else
TextBox1.Text = TextBox1.Text + 1
End If
End Sub

Private Sub SpinButton1_SpinDown()
If TextBox1.Text = 3 Then
TextBox1.Text = TextBox1.Text
Else
TextBox1.Text = TextBox1.Text - 1
End If
End Sub

Private Sub TextBox1_Change()
If Not IsNumeric(TextBox1) Then
TextBox1.Text = 3
mymsg1 = MsgBox("请输入3-9整数，已初始化为3", vbOKOnly, "提醒")
Else
If (TextBox1.Value - 3) * (TextBox1.Value - 4) * (TextBox1.Value - 5) * (TextBox1.Value - 6) * (TextBox1.Value - 7) * (TextBox1.Value - 8) * (TextBox1.Value - 9) <> 0 Then
TextBox1.Text = 3
mymsg1 = MsgBox("请输入3-9整数，已初始化为3", vbOKOnly, "提醒")
End If
End If
End Sub

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
Dim cc As Integer, mymin As Variant, mystring As String '必须养成给变量定义类型的习惯
On Error Resume Next
If Target.Count = 1 Then '判断目标区域为单元格时，执行后续语句
   If Target.Value = Y Then
        Target.Font.ColorIndex = mycolor3 '如果鼠标单击单元格为当前顺序数字，那么单元格变字体颜色为黑色
   'Call PlaySound("c:\windows\media\ir_end.wav", 0&, &H0)
   Y = Y + 1
   TextBox2.Text = Y
   If Y = TextBox1.Value ^ 2 + 1 Then
   mytime = Round(Timer - t, 2) '当完成所有数字的点击时，停止计时
   cc = TextBox1.Value
   mymin = Round(Application.Min(Sheet4.Range(Chr(cc + 62) & 3 & ":" & Chr(cc + 62) & 65536)), 2)
   If mymin > mytime Then
   mystring = "恭喜你创造了新纪录！"
   Else
   mystring = "继续加油！"
   End If
   mymsg = MsgBox("本次成绩为：" & mytime & "秒" & vbCrLf & "历史记录为：" & mymin & "秒" & vbCrLf & mystring, vbOKOnly, "成绩") '弹出包含计时等信息的对话框
   numb = Sheet4.Range(Chr(cc + 62) & 65536).End(xlUp).Row
   Sheet4.Cells(numb + 1, cc - 2).Value = mytime
   '将测试成绩写到sheet4中
   End If
   End If
End If
End Sub