EXCEL巧解数独(VBA)

DC = FirstC '求得的解的显示位置 DR = ggSN + FirstR + 2 MsgBox "数独初始化完成。" & vbCrLf & "请将数独中的基本数字输入，输入完毕后，执行 宏“数独求解”", 64, Title End Sub Sub 数独求解() If Vtc = "" Then MsgBox "您需要先运行宏：数独初始化", 48, ห้องสมุดไป่ตู้itle Exit Sub End If GetSD '将数据保存到数组中，提高速度 If GetSDV Then '取得各个位置的可能取值 ClearAWZ 0, 0 '初始化数据位置 GetValue '求解 End If End Sub Private Sub GetSD() '将初始化的结果保存到数组中，可以提高计算速度 Dim i%, j% Dim c$ Sheets("Sheet2").Select For i = 0 To ggSN For j = 0 To ggSN c = GetAddress(FirstR + i, FirstC + j) c = Trim(UCase(Range(c).Value)) If InStr(Vtc, c) = 0 Then MsgBox "输入的数据错误：" & c & vbCrLf & "可用的字符是：" & Vtc, 48, Title End End If SD(i, j) = c Next Next End Sub Private Function GetSDV() As Boolean '取得各个位置可能的取值 Dim i%, j% For i = 0 To ggSN For j = 0 To ggSN SDV(i, j) = GetValueHL(i, j) If SDV(i, j) = "" Then MsgBox "所给的数独无解，位置第" & i + 1 & "行" & j + 1 & "列", 16, Title Sheets("Sheet2").Select Range(GetAddress(FirstR + i, FirstC + j)).Select Exit Function
End If Next Next GetSDV = True End Function Private Function GetValueHL(ByVal h%, ByVal l%) As String '求位置 H,L 处的可能取值 Dim i%, j%, m%, n% Dim s$ If SD(h, l) <> "" Then '原来有值则取原来的值 GetValueHL = SD(h, l) Else s = Vtc For i = 0 To ggSN '检查第 H 行，保留可能的取值 s = Replace(s, SD(h, i), "") Next For i = 0 To ggSN '检查第 L 列，保留可能的取值 s = Replace(s, SD(i, l), "") Next '检查所在的宫格，保留可能的取值 m = (h \ ggN) * ggN n = (l \ ggN) * ggN For i = m To m + ggN - 1 For j = n To n + ggN - 1 s = Replace(s, SD(i, j), "") Next Next GetValueHL = s End If End Function Private Sub ClearAWZ(ByVal h As Integer, ByVal l As Integer) '将 WZ()的第 H,L 之后的计数位置置 1,并按照 WZ 来初始化 SD() Dim i% For i = h To ggSN Do While l <= ggSN If WZ(i, l) <> 1 Then WZ(i, l) = 1 SD(i, l) = Mid(SDV(i, l), 1, 1) End If l=l+1 Loop l=0 Next End Sub
Case 3 Vtc = "123456789" Case 4 Vtc = "0123456789ABCDEF" Case 5 Vtc = "123456789ABCDEFGHIJKLMNOP" Case 6 Vtc = "123456789ABCDEFGHIJKLMNOPQRSTUVWXYZ*" End Select If <> Title & ".xls" Then ActiveWorkbook.SaveAs Filename:=Title & ".xls" Sheets("Sheet2").Select ActiveWindow.DisplayGridlines = True Range("A:IV").Select With Selection .MergeCells = False .Borders().LineStyle = xlNone .Interior.ColorIndex = xlNone .ClearContents .HorizontalAlignment = xlCenter .ColumnWidth = 2.1 .RowHeight = 16 End With Range(GetAddress(FirstR, FirstC) & ":" & GetAddress(FirstR + ggSN, FirstC + ggSN)).Select Selection.Borders().LineStyle = xlContinuous Range(GetAddress(FirstR - 1, FirstC) & ":" & GetAddress(FirstR - 1, FirstC + ggSN)).Select With Selection .HorizontalAlignment = xlCenter .MergeCells = True .Value = ggN * ggN & "宫格数独" End With For i = 0 To ggN - 1 n = i Mod 2 For j = 0 To ggN - 1 If n = 0 Then Range(GetAddress(FirstR + i * ggN, FirstC + j * ggN) & ":" & GetAddress(FirstR + i * ggN + ggN - 1, FirstC + j * ggN + ggN - 1)).Select Selection.Interior.ColorIndex = 15 End If n=1-n Next Next Range(GetAddress(FirstR, FirstC)).Select DV = 1
Excel 巧解数独（VBA）
山东省荣成市委党校 刘振华 教育生活·测试空间中的数独题，然而我们需要几个小时能解出来呢？想象着我们苦思冥想 的样子，阴险的徐诚编辑不知要邪恶地笑多少次呢！想象着我们苦思冥想的样子，阴险的徐 诚编辑不知要邪恶地笑多少次呢！ 今天我就给大家一个方法：用我们平日常用的电子表格 Excel 来帮助我们求解数独。这个方 法不但可以求解 16 宫数独， 而且还可以求解 4 宫甚至 25 宫数独， 甚至还可以将某宫格数独 的所有可能解全部求出！比如 4 宫格数独共有 288 种解，只用几秒钟就可以将其全部求出。 有了这样的方法， 一方面可以让徐诚编辑的阴谋不再得逞， 另一方面也可让我们领略一下经 常使用的电子表格的另一些功能。电子表格 Excel 准备好了么？让我们开始吧！ 一、基础工作 这部分工作的任务是自动格式化电子表格， 并根据用户选择来格式化数独。 这部分工作只需 要做一次，以后可以永远使用： 1、打开 Excel，按下 Alt+F11 键或通过菜单“工具”、“宏”来打开“Visual Basic 编辑器”。 （如图 1） 2、在打开的窗口中，选择菜单“插入”、“模块”并将以下代码输入 Dim ggN% '宫格数 Dim ggSN% '总数组维数 Dim SD$() '初始化后的内容 Dim SDV$() '每个位置的可能取值 Dim WZ%() '每个位置的取值位置 Dim Vtc$ '数独中使用的填充数据 Dim DV#, DR&, DC& '数独第几套解，显示位置 Const Title$ = "刘振华解数独" Dim ChkR%, ChkC% '记录检测的位置 Const FirstR& = 2, FirstC& = 1 '数独的初始化位置 Sub 数独初始化() Dim i%, j%, n% On Error Resume Next ggN = InputBox("说明：2=4 宫格，3=9 宫格，4=16 宫格，5=25 宫格。" & vbCrLf & vbCrLf & "请输入数字 2 或 3 或 4 或 5：", Title, 3) If ggN <> 2 And ggN <> 3 And ggN <> 4 And ggN <> 5 And ggN <> 6 Then MsgBox "宫格数字设置错误。", 16, Title Exit Sub End If ggSN = ggN * ggN - 1 ReDim SD$(ggSN, ggSN) ReDim SDV$(ggSN, ggSN) ReDim WZ%(ggSN, ggSN) Select Case ggN '设置数独中使用的填充数据，可以根据实际情况修改成合理的内容 Case 2 Vtc = "1234"
Private Sub GetValue() '根据 SDV()和 WZ()遍历所有可能解,如果有解，则输出之 Dim i%, j% Dim tNow# '记录所用时间 Dim Drc$ tNow = CDbl(Time) Do Sheets("Sheet2").Select Drc = GetAddress(DR, DC) & ":" & GetAddress(DR, DC + ggSN) Sheets("Sheet2").Range(Drc).HorizontalAlignment = xlCenter Sheets("Sheet2").Range(Drc).MergeCells = True For ChkR = 0 To ggSN For ChkC = 0 To ggSN Do While CheckSD = False GetChkRChkC Loop Next Sheets("Sheet2").Range(Drc).Value = "'" & CDate(CDbl(Time) - tNow) DoEvents Next '输出答案 Sheets("Sheet2").Select Sheets("Sheet2").Range(Drc).Select Sheets("Sheet2").Range(Drc).Value = "答案" & DV & "：" DR = DR + 1 For i = 0 To ggSN For j = 0 To ggSN Sheets("Sheet2").Range(GetAddress(DR + i, DC + j)) = SD(i, j) Next Next DR = DR + ggSN + 3 '下一套解的显示位置 If DR > 65536 - ggSN Then DR = 1 DC = DC + ggSN + 2 If DC + ggSN > 256 Then MsgBox "因为更多的解无法显示，因此求解终止" & vbCrLf & "如果想将所有的解求出， 可联系作者更改代码将解保存到文件中。" & vbCrLf & "电子信箱：RC_LZH@", 64, Title End End If End If DV = DV + 1