[COLOR=#000000]Application.EnableEvents = False
[/COLOR][COLOR=#000000]Application.EnableEvents = True
anh Tiêu Phong viết code "dữ" quá , ngưỡng mộ
Giờ em có thắc mắc nhỏ nhờ anh Tiêu Phong giúp đở
em có vùng 8 ô x 8 ô
giờ người dùng đặt con hậu lên 1 vị trí bất kì , làm sao tự điền 7 con hậu vào 7 vị trí còn lại sao cho không có con nào ăn được con nào . Em nghĩ mãi chưa ra nhờ anh Tiêu Phong giúp với . hi hi
anh Tiêu Phong viết code "dữ" quá , ngưỡng mộ
Giờ em có thắc mắc nhỏ nhờ anh Tiêu Phong giúp đở
em có vùng 8 ô x 8 ô
giờ người dùng đặt con hậu lên 1 vị trí bất kì , làm sao tự điền 7 con hậu vào 7 vị trí còn lại sao cho không có con nào ăn được con nào . Em nghĩ mãi chưa ra nhờ anh Tiêu Phong giúp với . hi hi
tôi cũng đâu có biết làm đâu . híc
cái này đùa hay là thật vậy anh
Hình như đúng vậy, tôi chưa thử sắp lần nào được 8 con kể cả sắp bằng tay.
Private Sub Worksheet_Change(ByVal Target As Range)
Application.EnableEvents = False
Dim BanCo As Range, i As Long, j As Long, Rw As Long, Col As Long
Dim Giatri
Set BanCo = Sheet1.Range("F3:M10")
Rw = Target.Row - 2: Col = Target.Column - 5
Giatri = Target.Value
BanCo.ClearContents
Target.Value = Giatri
x = Rw: y = Col
If Not Intersect(Target, BanCo) Is Nothing Then
If Target.Count > 1 Then GoTo ExitSub
For i = Rw To Rw + 5
x = (x + 2)
If x > 8 Then x = x Mod 8 + 1
y = (y + 1)
If y > 8 Then y = y Mod 8 + 1
BanCo(x, y) = Giatri
Next i
End If
ExitSub:
Application.EnableEvents = True
End SubPhong có hình của 1 đáp án nào đó không?Ặc ặc ..
Trên mạng cũng có lời giải cho bài toán này nhưng mà người ta viết bằng C++. Không biết là dùng VBA có giải được bài tập này không.
Bác Ba chưa nắm quy tắc trò chơi rồi
Bác Ba chưa nắm quy tắc trò chơi rồi
Đây là tất cả các cách xếp. Đúng là có 92 cách xếp khác nhau.
Code sẽ được post sau.
Làm như lão chết tiệt không nói sai bao giờ á. Nhưng dù sai cũng ngó kết quả 1 cái chứ bạn già.
Private Sub Worksheet_Change(ByVal target As Range)
Dim myRgn As Range
Set myRgn = Me.Range("B" & "8" & ":" & "I" & "1" & "5")
If target.Count = 1 Then
If Not Intersect(target, myRgn) Is Nothing Then
If target.Value <> "" Then
Func1 myRgn, target
Else: myRgn.ClearContents: End If: End If: End If: End SubPrivate gbVar1 As Long
Sub Func1(ByVal pram1 As Range, ByVal pram2 As Range)
Dim Var1() As Boolean, Var2(1 To 8, 1 To 8) As String, Var4 As Long, Var5 As Long
ReDim Var1(1 To pram1.Rows.Count, 1 To pram1.Columns.Count)
Var1(pram2.Row - pram1.Row + 1, pram2.Column - pram1.Column + 1) = True
gbVar1 = 0
Func2 Var1, 1
For Var4 = 1 To 8
For Var5 = 1 To 8
If Var1(Var4, Var5) Then Var2(Var4, Var5) = pram2.Value
Next
Next
pram1.Value = Var2
End Sub
Private Sub Func2(ByRef Var1() As Boolean, ByVal pram4 As Long)
Dim Var4 As Long, Var5 As Long, Var8, Var9 As Long
If gbVar1 = 8 Then Exit Sub
For Var4 = 1 To 8
If Var1(pram4, Var4) Then
Func2 Var1, pram4 + 1
Exit Sub
End If
Next
Var8 = Var1
For Var9 = 1 To 8
If gbVar1 = 8 Then Exit Sub
Var1 = Var8
Var1(pram4, Var9) = True
If Not Func3(Var1) Then
Func2 Var1, pram4 + 1
End If
Next
End Sub
Function Func3(ByRef Var1() As Boolean) As Boolean
Dim Var4 As Long, Var5 As Long, Var12 As Boolean
For Var4 = 1 To 8
Var12 = False
For Var5 = 1 To 8
If Var1(Var4, Var5) And Var12 Then
Func3 = True
Exit Function
Else
Var12 = Var1(Var4, Var5) Or Var12
End If
Next
Var12 = False
For Var5 = 1 To 8
If Var1(Var5, Var4) And Var12 Then
Func3 = True
Exit Function
Else
Var12 = Var1(Var5, Var4) Or Var12
End If
Next
Next
For Var4 = 1 To 7
Var12 = False
For Var5 = 1 To Var4
If Var1(Var4 - Var5 + 1, Var5) And Var12 Then
Func3 = True
Exit Function
Else
Var12 = Var1(Var4 - Var5 + 1, Var5) Or Var12
End If
Next
Var12 = False
For Var5 = 1 To 9 - Var4
If Var1(Var4 + Var5 - 1, Var5) And Var12 Then
Func3 = True
Exit Function
Else
Var12 = Var1(Var4 + Var5 - 1, Var5) Or Var12
End If
Next
Var12 = False
For Var5 = 9 - Var4 To 8
If Var1(Var4 + Var5 - 8, Var5) And Var12 Then
Func3 = True
Exit Function
Else
Var12 = Var1(Var4 + Var5 - 8, Var5) Or Var12
End If
Next
Var12 = False
For Var5 = Var4 To 8
If Var1(8 + Var4 - Var5, Var5) And Var12 Then
Func3 = True
Exit Function
Else
Var12 = Var1(8 + Var4 - Var5, Var5) Or Var12
End If
Next
Next
gbVar1 = 0
For Var4 = 1 To 8
For Var5 = 1 To 8
If Var1(Var4, Var5) Then gbVar1 = gbVar1 + 1
Next
Next
End FunctionThấy vùng B8:I16 thì chắc là code của bạn huuthang_bd sau vài lần replace.được dịch từ VBA sang VBA , đố bạn biết VBA gốc nằm ở đâu ?
Code này đơn giản nên việc tìm và thay thế cũng không mấy khó khăn. Chỉ có điều tên biến không mô tả nội dung nó lưu trữ nên việc đọc cũng hơi khó khăn. Nếu một dự án lớn thì việc dịch ngược cũng mất không ít thời gian àđược dịch từ VBA sang VBA , đố bạn biết VBA gốc nằm ở đâu ?
Code này đơn giản nên việc tìm và thay thế cũng không mấy khó khăn. Chỉ có điều tên biến không mô tả nội dung nó lưu trữ nên việc đọc cũng hơi khó khăn. Nếu một dự án lớn thì việc dịch ngược cũng mất không ít thời gian à
Đã vậy thì tôi gửi code luôn vậy.
Cũng dạng này nhưng có đề bài khó hơn: Viết code giải ô số Sudoku. Ai có hứng thú thì nhào vô
Option Explicit
Private userRow As Long, userCol As Long, EndGame As Boolean, strResult As String
Private Sub Worksheet_Change(ByVal target As Range)
Dim BanCo As Range, giatri, r As Long
EndGame = False
Set BanCo = Sheet1.Range("B8:I16")
giatri = target.Value
If Not IsArray(giatri) And Not Intersect(target, BanCo) Is Nothing Then
userRow = target.Row - 7
userCol = target.Column - 1
hell 1, ""
If EndGame Then
Application.EnableEvents = False
BanCo.ClearContents
For r = 1 To 8 Step 1
BanCo(Mid(strResult, r, 1), r) = giatri
Next
Application.EnableEvents = True
Else
MsgBox "ho^ng? tim` thay'"
End If
End If
End Sub
Private Sub hell(Col As Long, tmp As String)
Dim r As Long, u As Long
If Not EndGame Then
If Col < 9 Then
If Col <> userCol Then
For r = 1 To 8 Step 1
If InStr(1, tmp, r) = 0 And r <> userRow Then
For u = 1 To Col - 1 Step 1
If Abs(Mid(tmp, u, 1) - r) = Col - u Then Exit For
Next
If u > Col - 1 And Abs(userRow - r) <> Abs(userCol - Col) Then hell Col + 1, tmp & r
End If
Next
Else
hell Col + 1, tmp & userRow
End If
Else
EndGame = True
strResult = tmp
End If
End If
End SubMình có đề bài gởi các bạnNếu thích giao lưu Soduku mà phải điền bằng tay thì khổ lắm
Bạn có lòng tốt thì giúp mọi người 1 đoạn code lấy đề bài Sudoku từ trên mạng xuống trước đi , để có cái mà làm .
Tôi dịch bằng VBA nên cũng chẳng có gì ngạc nhiên khi một ai đó dùng VBA để dịch lại. Tuy nhiên cũng bởi vì tôi tự làm nên tôi biết không đơn giản chỉ là thay thế các biến.mình không được học hành gì nhiều , nên chỉ biết tự viết mã để replace các kí tự thôi à
Nếu có lòng , mời bạn cho mình thưởng thức dự án không nhỏ nào đó để giúp mình hoàn thiện cỗ máy replace với
Đề Sudoku thì dễ thôi. Bạn HieuCD đã đưa lên rồi đấy. Chắc đủ cho bạn test, khỏi cần lấy trên mạng nữa nhỉ.Nếu thích giao lưu Soduku mà phải điền bằng tay thì khổ lắm
Bạn có lòng tốt thì giúp mọi người 1 đoạn code lấy đề bài Sudoku từ trên mạng xuống trước đi , để có cái mà làm .
kết quả thôi, còn code của mình không đúng nghĩa là code, chỉ làm bán thủ công thôiđáp án nghĩa là code giải sudoku hả ? gửi đi bạn . Tôi đang thắc không biết mình có sai ở đâu không mà sao thấy bài này dễ quá , nhiều khi tôi lầm ở đâu chăng ? nên bạn cho tôi tham khảo code của bạn nhé .
giải được tức là nội công đã tăng lên , sắp trở thành cao thủ , sướng nhé .
Option Explicit
Private arrResult
Public Sub hello()
Dim arr, r As Long, c As Long, dArr, str As String
arr = Sheet2.Range("A12").Resize(9, 9).Value
arrResult = ""
Solve arr
Sheet2.Range("M2").Resize(9, 9).ClearContents
Sheet2.Range("M2").Resize(9, 9).Value = arrResult
End Sub
Private Sub Solve(ByVal arr)
If Not IsArray(arrResult) Then
Dim r As Long, c As Long, tmpMin(1 To 3), str, has1situ As Boolean
For r = 1 To 9 Step 1
For c = 1 To 9 Step 1
If arr(r, c) = "" Then
str = situ(r, c, arr)
If Len(str) = 0 Then GoTo kt
If Len(str) = 1 Then
arr(r, c) = str
has1situ = True
Else
If Not has1situ Then
If Len(tmpMin(3)) = 0 Or Len(str) < Len(tmpMin(3)) Then
tmpMin(1) = r: tmpMin(2) = c: tmpMin(3) = str
End If
End If
End If
End If
Next
Next
If IsFinish(arr) Then
arrResult = arr
Else
If has1situ Then
Solve arr
Else
For r = 1 To Len(tmpMin(3)) Step 1
arr(tmpMin(1), tmpMin(2)) = Mid(tmpMin(3), r, 1)
Solve arr
Next
End If
End If
End If
kt:
End Sub
'get all situation for target cell ( i , j)
Private Function situ(i As Long, j As Long, arr) As String
Dim r As Long, c As Long
situ = "123456789"
For c = 1 To 9 Step 1
If arr(i, c) <> "" Then situ = Replace(situ, arr(i, c), "")
Next
For r = 1 To 9 Step 1
If arr(r, j) <> "" Then situ = Replace(situ, arr(r, j), "")
Next
For r = 3 * WorksheetFunction.RoundUp(i / 3, 0) - 2 To 3 * WorksheetFunction.RoundUp(i / 3, 0) Step 1
For c = 3 * WorksheetFunction.RoundUp(j / 3, 0) - 2 To 3 * WorksheetFunction.RoundUp(j / 3, 0) Step 1
If arr(r, c) <> "" Then situ = Replace(situ, arr(r, c), "")
Next
Next
End Function
Private Function IsFinish(arr) As Boolean
Dim r As Long, c As Long
IsFinish = False
For r = 1 To 9 Step 1
For c = 1 To 9 Step 1
If arr(r, c) = "" Then Exit Function
Next
Next
IsFinish = True
End FunctionCode quá hay, bạn làm thêm đường chéo cho hoàn chỉnh
[TABLE="width: 261"]
