Challenge : Chương trình VBA của bạn có thể giải ô Sudoku khó nhất thế giới này trong 3.461s không?
Mình vừa học VBA từ zero và hoàn thành dự án này trong 2 tuần, tài liệu sử dụng : Microsoft Excel 2010 Power Programming with VBA
Option Explicit
Option Base 1
Sub Sudoku5()
'Thu viet ung dung giai sudoku voi Array
'Khai bao bien
Dim DoKu(9, 9) As String
Dim RanCurrent(1) As Variant
Dim intX, intY, intZ, intX1, intY1 As Integer
Dim CurVar, CurVar1 As String
Dim k, i, g, m, sum1, sum2 As Integer
Dim StartTime As Single
On Error GoTo KT
StartTime = Timer
g = 1
k = 1
m = 1
'Dua du lieu vao mang
For intX = 1 To 9
For intY = 1 To 9
DoKu(intX, intY) = Cells(intX, intY)
If Cells(intX, intY) = vbNullString Then
Cells(intX, intY).Interior.Color = 65535
End If
Next intY
Next intX
'Thu du lieu theo dong,cot, mang
TH1:
sum1 = 0
sum2 = 0
'Tinh sum1
For intX1 = 1 To 9
For intY1 = 1 To 9
If DoKu(intX1, intY1) = vbNullString Then
sum1 = sum1 + 1
End If
Next intY1
Next intX1
For intX = 1 To 9
For intY = 1 To 9
If DoKu(intX, intY) = vbNullString Then
CurVar = "123456789"
'Thu du lieu theo dong
For intX1 = 1 To 9
If intX1 <> intX Then
CurVar1 = DoKu(intX1, intY)
End If
CurVar = Replace(CurVar, CurVar1, vbNullString)
Next intX1
'Thu du lieu theo cot
If Len(CurVar) > 1 Then
For intY1 = 1 To 9
If intY1 <> intY Then
CurVar1 = DoKu(intX, intY1)
End If
CurVar = Replace(CurVar, CurVar1, vbNullString)
Next intY1
End If
'Thu du lieu theo nhom 3x3
If Len(CurVar) > 1 Then
Select Case intX
Case intX = 1 To 3
Select Case intY
Case intY = 1 To 3: RanCurrent(UBound(RanCurrent)) = Array(DoKu(1, 1), DoKu(1, 2), DoKu(1, 3), DoKu(2, 1), DoKu(2, 2), DoKu(2, 3), DoKu(3, 1), DoKu(3, 2), DoKu(3, 3))
Case intY = 4 To 6: RanCurrent(UBound(RanCurrent)) = Array(DoKu(1, 4), DoKu(1, 5), DoKu(1, 6), DoKu(2, 4), DoKu(2, 5), DoKu(2, 6), DoKu(3, 4), DoKu(3, 5), DoKu(3, 6))
Case intY = 7 To 9: RanCurrent(UBound(RanCurrent)) = Array(DoKu(1, 7), DoKu(1, 8), DoKu(1, 9), DoKu(2, 7), DoKu(2, 8), DoKu(2, 9), DoKu(3, 7), DoKu(3, 8), DoKu(3, 9))
End Select
Case intX = 4 To 6
Select Case intY
Case intY = 1 To 3: RanCurrent(UBound(RanCurrent)) = Array(DoKu(4, 1), DoKu(4, 2), DoKu(4, 3), DoKu(5, 1), DoKu(5, 2), DoKu(5, 3), DoKu(6, 1), DoKu(6, 2), DoKu(6, 3))
Case intY = 4 To 6: RanCurrent(UBound(RanCurrent)) = Array(DoKu(4, 4), DoKu(4, 5), DoKu(4, 6), DoKu(5, 4), DoKu(5, 5), DoKu(5, 6), DoKu(6, 4), DoKu(6, 5), DoKu(6, 6))
Case intY = 7 To 9: RanCurrent(UBound(RanCurrent)) = Array(DoKu(4, 7), DoKu(4, 8), DoKu(4, 9), DoKu(5, 7), DoKu(5, 8), DoKu(5, 9), DoKu(6, 7), DoKu(6, 8), DoKu(6, 9))
End Select
Case intX = 7 To 9
Select Case intY
Case intY = 1 To 3: RanCurrent(UBound(RanCurrent)) = Array(DoKu(7, 1), DoKu(7, 2), DoKu(7, 3), DoKu(8, 1), DoKu(8, 2), DoKu(8, 3), DoKu(9, 1), DoKu(9, 2), DoKu(9, 3))
Case intY = 4 To 6: RanCurrent(UBound(RanCurrent)) = Array(DoKu(7, 4), DoKu(7, 5), DoKu(7, 6), DoKu(8, 4), DoKu(8, 5), DoKu(8, 6), DoKu(9, 4), DoKu(9, 5), DoKu(9, 6))
Case intY = 7 To 9: RanCurrent(UBound(RanCurrent)) = Array(DoKu(7, 7), DoKu(7, 8), DoKu(7, 9), DoKu(8, 7), DoKu(8, 8), DoKu(8, 9), DoKu(9, 7), DoKu(9, 8), DoKu(9, 9))
End Select
End Select
For intZ = 1 To 9
CurVar1 = RanCurrent(1)(intZ)
CurVar = Replace(CurVar, CurVar1, vbNullString)
Next intZ
End If
'Neu ra nghiem 1 so thi ghi vao DoKu
If Len(CurVar) = 1 Then
DoKu(intX, intY) = CurVar
End If
'Neu ra nghiem 2 so thi den TH2 Thu nghiem
If Len(CurVar) = 2 And k = 2 Then
GoTo TH2
End If
'Neu ra vo nghiem thi den TH3 Quay lai
If CurVar = vbNullString And g > 1 Then
GoTo TH3
End If
End If
Next intY
Next intX
'Tinh sum2
For intX1 = 1 To 9
For intY1 = 1 To 9
If DoKu(intX1, intY1) = vbNullString Then
sum2 = sum2 + 1
End If
Next intY1
Next intX1
'Neu sum2 = 0, sudoku hoan thanh
If sum2 = 0 Then
GoTo KT
End If
'Neu sum2 = sum1, sudoku khong co tien trien
If sum2 = sum1 Then
k = 2
End If
GoTo TH1
'2. Neu gap truong hop 2 so, phai lua chon 1
TH2:
'Tao mot sheet moi
If g = m Then
Sheets.Add.Name = "Try" & g
Sheets("Sheet1").Select
m = m + 1
End If
Sheets("Try" & g).[A1:I9] = DoKu
Sheets("Try" & g).Cells(intX, intY) = Right(CurVar, 1)
g = g + 1
k = 1
DoKu(intX, intY) = Left(CurVar, 1)
GoTo TH1
' 3. Neu ket qua vo nghiem, quay lai lua chon truoc
TH3:
If IsEmpty(Sheets("Try" & (g - 1)).[A1:I9]) Then
g = g - 1
GoTo TH3
End If
For intX = 1 To 9
For intY = 1 To 9
DoKu(intX, intY) = Sheets("Try" & (g - 1)).Cells(intX, intY)
Next intY
Next intX
Sheets("Try" & (g - 1)).[A1:I9].ClearContents
g = g - 1
k = 1
GoTo TH1
KT:
' 4. Xoa het cac sheet Try
Application.DisplayAlerts = False
For i = 1 To m
If i <> 1 Then
Sheets("Try" & (i - 1)).Delete
End If
Next i
Application.DisplayAlerts = True
'Ghi ket qua
[A1:I9] = DoKu
Range("A11") = Timer - StartTime
Range("H11") = m - 1
End Sub
Sub Test1()
Dim Cell As Range
Dim DoKu As String
For Each Cell In Selection
DoKu = DoKu & "DoKu(" & Cell & ") ,"
Next Cell
[A19] = DoKu
End Sub
Sub Test2()
Dim i, j As Integer
For i = 1 To 9
For j = 1 To 9
Cells(i, j) = i & "," & j
Next j
Next i
End Sub
Sub Test3()
Dim Arr(1) As Variant
Arr(1) = Array(1, 2, 3, 4, 5, 6, 7, 8, 9)
[A11] = Arr(1)(3)
End Sub
-----------------------------------------------------------------------
Like & Share bài viết cho bạn bè của bạn,
.
Chat với #LongNguyenCIA để được tư vấn về khoá học CIA online:
https://m.me/nguyenvulong.cia
.
Giới thiệu về Team #LongNguyenCIA
1) Hoàn thành CIA trong 10 tháng : http://bit.ly/getCIAin10months
2) Hoàn thành CISA (663/800 điểm) trong 6 tháng : http://bit.ly/getCISAin6months
.
Cảm nhận của học viên về khoá học CIA với Team #LongNguyenCIA
: http://bit.ly/ReviewsTeamLongNguyenCIA
.
CIA Vietnam Community: https://www.facebook.com/groups/cia.vietnam hy vọng có thể cùng nhau chia sẻ chuyện nghề, chuyện học kiểm toán nội bộ,-----------------------------------------------------------------------
