|
楼主 |
发表于 2013-10-23 11:35
|
显示全部楼层
按初始可选数排序代码如下:- Sub sudoku2()
- Dim ar, i&, j&, jg&(1 To 81), x&, t&, tt, jwz&(1 To 81), jcs(1 To 81), y&, xx&(1 To 9), k&, b&
- Dim f_g&(1 To 9, 1 To 9), f_h&(1 To 9, 1 To 9), f_l&(1 To 9, 1 To 9)
- Dim g&(1 To 81), h&(1 To 81), l&(1 To 81)
- tt = Timer
- ar = Sheet1.[b2].Resize(9, 9)
- For i = 1 To 81
- jcs(i) = xx
- Next
- For i = 1 To 9
- For j = 1 To 9
- x = x + 1
- h(x) = i: l(x) = j
- g(x) = ((i - 1) \ 3) * 3 + (j - 1) \ 3 + 1
- jg(x) = ar(i, j)
- If jg(x) > 0 Then
- If f_g(g(x), jg(x)) + f_h(h(x), jg(x)) + f_l(l(x), jg(x)) > 0 Then MsgBox "无解": Exit Sub
- f_g(g(x), jg(x)) = 1
- f_h(h(x), jg(x)) = 1
- f_l(l(x), jg(x)) = 1
- Else
- y = y + 1
- jwz(y) = x
- For k = 1 To 9
- If ar(i, k) Then jcs(x)(ar(i, k)) = 1
- If ar(k, j) Then jcs(x)(ar(k, j)) = 1
- Next
- For b = ((i - 1) \ 3) * 3 + 1 To ((i - 1) \ 3) * 3 + 3
- For k = ((j - 1) \ 3) * 3 + 1 To ((j - 1) \ 3) * 3 + 3
- If ar(b, k) Then jcs(x)(ar(b, k)) = 1
- Next
- Next
- k = 0
- For b = 1 To 9
- k = k + jcs(x)(b)
- Next
- jcs(y) = k
- End If
- Next
- Next
- For i = 1 To y - 1
- For j = y To i + 1 Step -1
- If jcs(j) > jcs(j - 1) Then
- k = jcs(j): jcs(j) = jcs(j - 1): jcs(j - 1) = k
- k = jwz(j): jwz(j) = jwz(j - 1): jwz(j - 1) = k
- End If
- Next
- Next
- j = 1: t = 1
- Do
- If j > y Then Exit Do
- x = jwz(j)
- For i = jg(x) + 1 To 9
- If f_g(g(x), i) = 0 Then
- If f_h(h(x), i) = 0 Then
- If f_l(l(x), i) = 0 Then
- jg(x) = i: t = 1
- f_g(g(x), jg(x)) = 1
- f_h(h(x), jg(x)) = 1
- f_l(l(x), jg(x)) = 1
- Exit For
- End If
- End If
- End If
- Next
- If i > 9 Then
- t = -1
- jg(x) = 0
- If j > 1 Then
- x = jwz(j - 1)
- f_g(g(x), jg(x)) = 0
- f_h(h(x), jg(x)) = 0
- f_l(l(x), jg(x)) = 0
- Else
- MsgBox "无解": Exit Sub
- End If
- End If
- j = j + t
- Loop
- For i = 1 To 81
- ar(h(i), l(i)) = jg(i)
- Next
- Sheet1.[b12].Resize(9, 9) = ar
- MsgBox Format(Timer - tt, "0.000s ")
- Sheet1.[b12].Resize(9, 9).Interior.ColorIndex = -4142
- Sheet1.[b2].Resize(9, 9).SpecialCells(xlCellTypeConstants, 1).Offset(10).Interior.Color = vbRed
- End Sub
复制代码 对下面这道题效果明显
*********
*21*4****
**4**6***
5**6*3***
*****8***
**9***2*1
8******6*
****2*4**
*******3*
|
|