Sudoku_việt nam

Liên hệ QC
T

thuongg

Thành viên chính thức
Tham gia
27/3/07
Bài viết
53
Được thích
4
em xin chầo các bác, tình cờ thấy có 1 trò chơi tương tự SUKU nên gởi lên đây
xem có cách nào giải tối ưu bài toán này không?
CHo ma trận NxM không quá 50
cho các số bên lề phải,
cho các số ở cạnh dưới cùng...
cho số 1 ở trong lưới (không được duy chuyển hay sửa đổi , nhưng tính tổng thì có cộng)
cho các ô màu tối (không được sửa đổi hay điền bất cứ số nào vào)
các số có thể điền là 0,1,2,3,4
Hãy điền vào lưới sao cho thỏa mãn dòng và cột (nếu có thể hãy cho tối ưu bằng cách hạn chế xài số 1)---> xin xem file kèm
THanks cac Bác

Tổng từ B2:K2 = L2 và L2 phải bằng M2 (Nghiĩa là b8àng 13)......
Tương tự ......
Tuong tự Sum(B2:B38) phải b8àng B39 (nghĩa là =88)
tuong tự.......
 

File đính kèm

  • SuDOKU_NEW12.xls
    19 KB · Đọc: 256
Chỉnh sửa lần cuối bởi điều hành viên:
hic 9 lần tải roài!!!!! em vẫn đang thăm từng giờ....
 
em bảo đảm là có đáp số (nhiều đs nữa đó) nhưng nếu mình làm bằng tay thì... chậm là mất gần 1 ngày còn nhanh là mất khoảng 2..4 h là xong, vậy tại sao mình không làm cho máy chạy được nhỉ?chắc là thiếu thuật toán....mà nếu có TT rồi thì cài đặt mất bao lâu? hic hic hic
lúc đó chắc được bù lại là máy tính giải trong 1s
Vậy cái nào có lợi hơn nhỉ?
 
thuongg đã viết:
em bảo đảm là có đáp số (nhiều đs nữa đó) nhưng nếu mình làm bằng tay thì... chậm là mất gần 1 ngày còn nhanh là mất khoảng 2..4 h là xong, vậy tại sao mình không làm cho máy chạy được nhỉ? chắc là thiếu thuật toán....mà nếu có TT rồi thì cài đặt mất bao lâu? hic hic hic
lúc đó chắc được bù lại là máy tính giải trong 1s
Vậy cái nào có lợi hơn nhỉ?
Nhấp chuột vào đây để mở rộng...
Sở dĩ không ai quan tâm có thể là người ta không hứng thú
Không biết ai khác thì sao chứ với riêng tôi, trước giờ chưa hề biết Sudoku là cái gi, chơi như thế nào (dù thấy người ta chơi rầm rầm) ---> Nói chung là không hứng thú, cũng không quan tâm đến
Ẹc... Ẹc...
 
ndu96081631 đã viết:
Sở dĩ không ai quan tâm có thể là người ta không hứng thú
Không biết ai khác thì sao chứ với riêng tôi, trước giờ chưa hề biết Sudoku là cái gi, chơi như thế nào (dù thấy người ta chơi rầm rầm) ---> Nói chung là không hứng thú, cũng không quan tâm đến
Ẹc... Ẹc...
Nhấp chuột vào đây để mở rộng...

vậy là Bác chỉ nặng về ứng dụng cụ thể thôi (đa số là excel), còn về tư duy cho ứng dụng khác thì bác không thích phát triển nhệ, theo mình nghĩ thì đã biết và học môn TINHOC rồi thì nếu có khả năng hay có thê thì...các BT mang màu sác8 TINHOC ta nên làm ráo trọi thì sẽ tốt hơn chứ
 
Lần chỉnh sửa cuối:
Nếu đề tài này trong BOX lập trình, chúng ta sẽ tiếp tục

PHP: 
Option Explicit
Dim cRng As Range
Const Cr As Integer = 54 
Sub SuDuVN()
 Dim Rng As Range, Clls As Range, bRng As Range
 Dim jJ As Byte
  
 Set Rng = Range("B2:K38")
 For Each Clls In Rng
    If Clls.Interior.ColorIndex = Cr Then
        If cRng Is Nothing Then
            Set cRng = Clls
        Else
            Set cRng = Union(cRng, Clls)
        End If
    End If
 Next Clls
 
 For jJ = 2 To 38
    If Not RngColor(Cells(jJ, "B").Resize(, 10), False) Is Nothing Then
'        MsgBox RngColor(Cells(jJ, "B").Resize(, 10), False).Address '
    End If
 Next jJ
End Sub

Mã: 
[B]Function RngColor(Rng As Range, Optional bBlank As Boolean = True) As Range[/B]
 Dim Clls As Range, Rng0 As Range
 For Each Clls In Rng
    If Not Intersect(Clls, cRng) Is Nothing Xor bBlank Then
        If RngColor Is Nothing Then
            Set RngColor = Clls
        Else
            Set RngColor = Union(RngColor, Clls)
        End If
    End If
 Next Clls
[B]End Function[/B]
 
hic, mình thấy có thỏa mãn gì đâu nào? hàng dưới cùng =88 la max chứ đâu la 89?
rồi các ô màu tối là số 4?????
 
'Công trình' chào mừng Tết nguyên đán!

Phần việc còn lại là của người chơi; Lúc rảnh rỗi sẽ tiếp tục sau!
PHP: 
Option Explicit
Dim cRng As Range, Clls As Range, sRng As Range
Const Cr As Integer = 54
Dim StrC As String:                           Dim SoDu As Double, jJ As Byte

Sub SuDuVN()
 On Error GoTo LoiSDK
 Dim Rng As Range
 Dim TgMau As Byte
 Dim DemO As Double
1 '. Xac Dinh Vung Da To Mau'
 Application.ScreenUpdating = False
 Set Rng = Range("B2:K38")
 For Each Clls In Rng
    If Clls.Interior.ColorIndex = Cr Then
        If cRng Is Nothing Then
            Set cRng = Clls
        Else
            Set cRng = Union(cRng, Clls)
        End If
    Else
        If sRng Is Nothing Then
            Set sRng = Clls
        Else
            Set sRng = Union(sRng, Clls)
        End If
    End If
 Next Clls
 On Error Resume Next
 cRng.SpecialCells(4).Value = 0      'xlCellTypeBlanks=4'
 On Error GoTo 0
 sRng.Value = "":                               [A2] = ""
2 '. Tim Gia Tri Cac Cot Co The Chua'
 For jJ = 2 To 11
    Set Rng = Cells(2, jJ).Resize(37)
    SoDu = WorksheetFunction.Sum(Rng)
    SoDu = 1000 * (Cells(39, jJ).Value - SoDu) / RngColor(Rng).Cells.Count
    Cells(jJ, "P") = Int(SoDu)
    If SoDu > 4000 Then
        MsgBox "Khong The!":                    Exit Sub
    ElseIf SoDu = 4000 Then
        RngColor(Cells(2, jJ).Resize(37)).Value = 4
    End If
 Next jJ
3 '. Xep Trat Tu Chuoi Giam Dan Cua Cac Cot'
 Set Rng = Range("P1:P11")
 For jJ = 2 To 11
    With Cells(jJ, "Q")
        Set sRng = Rng.Find(what:=.Value, LookIn:=xlValues)
        If sRng.Offset(, -1).Value <> .Offset(-1, 1) Then
            .Offset(, 1).Value = sRng.Offset(, -1)
        Else
            .Offset(, 1) = Rng.FindNext(sRng).Offset(, -1) '!'
        End If
        StrC = StrC & .Offset(, 1)
    End With
 Next jJ
4 ' Dien Gia Tri Vo Cac O Tu Cao Xuong Thap'
 For jJ = 2 To 38
    Set sRng = RngColor(Cells(jJ, "B").Resize(, 10))
    If Not sRng Is Nothing Then
      TgMau = 0
      If Not RngColor(Cells(jJ, "B").Resize(, 10), False) Is Nothing Then _
            TgMau = WorksheetFunction.Sum(RngColor(Cells(jJ, "B").Resize(, 10), False))
        With Cells(jJ, "M")
            DemO = (.Value - .Offset(, -1)) / sRng.Cells.Count  '- TgMau'
        End With
        Select Case DemO
        Case Is > 4
            MsgBox jJ:                              Exit Sub
        Case 4
            sRng.Value = 4:                 Cells(jJ, "A").Interior.ColorIndex = 38
        Case Is >= 3:                               MotHaiBa 3
        Case Is >= 2:                               MotHaiBa 2
        Case Is >= 1:                               MotHaiBa 1
        End Select
         
    End If
 Next jJ
 Set cRng = Nothing
errSDK:                 Exit Sub
LoiSDK:
    MsgBox jJ, , Error & " Erl:" & Erl
    Resume errSDK
End Sub
Mã: 
[B]Sub MotHaiBa(GPE As Byte)[/B]
 Dim jF As Byte, bDu As Byte
 Cells(jJ, "A").Interior.ColorIndex = 34 + GPE
 With Cells(jJ, "M")
    SoDu = .Value - .Offset(, -1) - GPE * Cells(jJ, "B").Resize(, 10). _
        SpecialCells(4).Cells.Count    '3'
 End With
 If SoDu = 0 Then
    Cells(jJ, "B").Resize(, 10).SpecialCells(4).Value = GPE '3'
 ElseIf SoDu > 0 Then
    bDu = 0
    For jF = 1 To 10
        If Not Intersect(Cells(jJ, Mid(StrC, jF, 1)), sRng) Is Nothing Then
            Cells(jJ, Mid(StrC, jF, 1)).Value = GPE + 1 '4'
            bDu = bDu + 1
        Else
        End If
        If bDu = SoDu Then Exit For
    Next jF
 End If
 Set Clls = Union([A2], sRng).SpecialCells(4)
 If Clls.Cells.Count > 1 Then
    With sRng.SpecialCells(4)
        If .Cells.Count = (Cells(sRng.Row, "M") - Cells(sRng.Row, "L")) / GPE Then
            .Value = GPE  '3*3'
        End If
    End With
 End If

[B]End Sub[/B]

PHP: 
Function RngColor(Rng As Range, Optional bBlank As Boolean = True) As Range
 Dim Clls As Range, Rng0 As Range
 For Each Clls In Rng
    If Not Intersect(Clls, cRng) Is Nothing Xor bBlank Then
        If RngColor Is Nothing Then
            Set RngColor = Clls
        Else
            Set RngColor = Union(RngColor, Clls)
        End If
    End If
 Next Clls
End Function
 

File đính kèm

  • GPE.rar
    23.6 KB · Đọc: 34
Lần chỉnh sửa cuối:
Hoàn tất rồi đây, xin xem trong file đính kèm.

PHP: 
Sub ChinhCot()
 Dim Rng As Range
 Dim StrD As String, StrA As String, ColD As String, ColA As String
 Dim Num1 As Byte, Ww As Byte, NumD As Byte, NumA As Byte
 Set Rng = Range("S2:S11")
 For Each Clls In Rng
    If Clls.Value > 0 Then
        StrD = StrD & Clls.Offset(, -4).Value
        Num1 = Num1 + Clls.Value
    Else
        StrA = StrA & Clls.Offset(, -4).Value
    End If
 Next Clls
 NumD = 1:                                  NumA = 1
 Set Rng = Rng.Offset(, -4)
 For Ww = 1 To Num1
    ColD = Mid(StrD, NumD, 1):                  ColA = Mid(StrA, NumA, 1)
 
    ChinhHang ColD, ColA
    With Cells(39, ColD)
        If .Offset(1) = .Value Then NumD = 1 + NumD
    End With
    With Cells(39, ColA)
        If .Offset(1) = .Value Then NumA = 1 + NumA
    End With
 Next Ww
 If [T2] > Abs([T4]) Then Num1 = Abs([T4]) Else Num1 = [T2]
 ColD = Range("S2:S11").Find(what:=[T2], lookat:=xlWhole).Offset(, -4)
 ColA = Range("S2:S11").Find(what:=[T4], lookat:=xlWhole).Offset(, -4)
 
 ChinhHang ColD, ColA, Num1
 
End Sub
Mã: 
Sub ChinhHang(ColD As String, ColA As String, Optional Num1 As Byte)
 For jJ = 2 To 38
    If Cells(jJ, ColD).Interior.ColorIndex <> Cr And _
        Cells(jJ, ColA).Interior.ColorIndex <> Cr And _
        Cells(jJ, ColD).Value < 4 And Cells(jJ, ColA) > 0 Then
        Cells(jJ, ColA) = Cells(jJ, ColA) - 1
        Cells(jJ, ColD) = Cells(jJ, ColD) + 1
        Cells(jJ, ColA).Font.ColorIndex = 3
        Cells(jJ, ColD).Font.ColorIndex = 5
        If Num1 > 0 Then
            Num1 = Num1 - 1
        Else
            Exit For
        End If
    End If
 Next jJ
End Sub
 

File đính kèm

  • GPE.rar
    23.6 KB · Đọc: 52
Chỉnh sửa lần cuối bởi điều hành viên:
HE, cũng hah nhưng chửa tối ưu bác à, nhất là cái dòng gần cuối VP=8 ó gì mà 1 1 1 1 1 1 1 ???
quá xấu ạ, nếu đc bác có thể cho nó là cột lẻ thì buộc KQ dọc phải là 88 , cột chẵn thì dao động từ 79.. .
 
Em thấy giải pháp của bác chưa đc tối ưu hóa cho lắm, em mạn phép share file của em
 

File đính kèm

  • Sodoku - ManhCuong.xls
    88 KB · Đọc: 31
tính vào chơi thử xem nó ra làm sao mà đọc thấy có pass haha
 
Tôi có 1 file có vẻ tương tự, ai thích thì xem thử:
 

File đính kèm

  • sudoku3.xls
    105 KB · Đọc: 17
Bạn phải đăng nhập hoặc đăng ký để trả lời bài viết tại đây.
Web KT

Bài viết mới nhất

H
Nhờ hướng dẫn chuyển hàng thành cột và dữ liệu theo nhu cầu bằng VBA
Trả lời
1
Đọc
47
DeTong
D
H
  • Question
Code VBA cho kết quả dòng, cột theo điều kiện từ 2 Sheets
Trả lời
2
Đọc
71
SA_DQ
SA_DQ
NguyenthiH
  • Question
Code lấy dữ liệu cho sheet!TonDau.
Trả lời
2
Đọc
61
NguyenthiH
NguyenthiH
T
Cần giúp sao chép C1 từ B1
Trả lời
3
Đọc
82
tle2003
T
A
Tìm số nhỏ nhất, số lớn nhất theo ngày
Trả lời
6
Đọc
76
hoangtuaotrang_hp_vn
H
Xem thêm…

Facebook

Giaiphapexcel.com

Group

DIỄN ĐÀN GIẢI PHÁP EXCEL

Thành viên có số lượng bài viết cao nhất tháng

Thành viên có điểm tương tác cao nhất tháng

Back
Top Bottom