Tính tổ hợp bằng Excel (1 người xem)

Liên hệ QC

Người dùng đang xem chủ đề này

kieunhu91

Thành viên mới
Tham gia
7/3/11
Bài viết
15
Được thích
0
Em có các nhóm (tối đa là 8 nhóm) được ghi lần lượt từ cột A-> cột H. (xem thêm trong file đính kèm)
Trong mỗi nhóm có tối đa là 6 phần tử, tối thiểu là 1 phần tử. Cột rỗng thì coi như là không có nhóm, trong file ví dụ, cột E,F,G,H rỗng.
(chú ý: các nhóm lần lượt được ghi từ cột A sang phía bên phải, liên tiếp nhau-không có chuyện giữ nhóm 1 và nhóm 2 là một cột rỗng! )
Em cần hiện kết quả tổ hợp, các phần tử của mỗi nhóm kết hợp với nhau,kết quả được tính và ghi ở dòng số 10 trở đi.
(ví dụ: xem kết quả ở file đính kèm, trong file đính kèm em tô màu cho dễ nhìn, thực tế thì em chỉ cần kết quả tổ hợp thôi, không cần tô màu ạ ^^ )

Ai có thể giúp em viết macro làm việc này không, mỗi lần phải dùng chuột copy tổ hợp các nhóm lại với nhau mệt quá **~**

http://www.mediafire.com/?oz9k3lucdas7dqr

( Em biết trong excel số dòng tối đa là 65536. Nếu dữ kiện cho ở trên thì số tổ hợp tối đa là 6^8, sẽ vượt quá con số 65536. Tuy nhiên trong bài toán của em, số phần tử tối đa trong nhóm là 6 phần tử, nhưng thực tế thì không phải lúc nào cũng có nhóm nào có 6 phần tử, họa hoằn lắm mới xuất hiện 1 nhóm như vậy thôi, đa phần các nhóm thường là 2-3 phần tử ^^, nên anh chị yên tâm là sẽ không bị tràn bộ nhớ , hihi. Em viết mãi thuật toán mà không được, khó quá đi mất, anh chị giúp em với nhé)
 
Lần chỉnh sửa cuối:
Theo mình, bài toán của bạn là

Liệt kê các phần tử của tích đê các của 8 tập hợp....
 
Upvote 0
Em có các nhóm (tối đa là 8 nhóm) được ghi lần lượt từ cột A-> cột H. (xem thêm trong file đính kèm)
Trong mỗi nhóm có tối đa là 6 phần tử, tối thiểu là 1 phần tử. Cột rỗng thì coi như là không có nhóm, trong file ví dụ, cột E,F,G,H rỗng.
(chú ý: các nhóm lần lượt được ghi từ cột A sang phía bên phải, liên tiếp nhau-không có chuyện giữ nhóm 1 và nhóm 2 là một cột rỗng! )
Em cần hiện kết quả tổ hợp, các phần tử của mỗi nhóm kết hợp với nhau,kết quả được tính và ghi ở dòng số 10 trở đi.
(ví dụ: xem kết quả ở file đính kèm, trong file đính kèm em tô màu cho dễ nhìn, thực tế thì em chỉ cần kết quả tổ hợp thôi, không cần tô màu ạ ^^ )

Ai có thể giúp em viết macro làm việc này không, mỗi lần phải dùng chuột copy tổ hợp các nhóm lại với nhau mệt quá **~**

http://www.mediafire.com/?oz9k3lucdas7dqr

( Em biết trong excel số dòng tối đa là 65536. Nếu dữ kiện cho ở trên thì số tổ hợp tối đa là 6^8, sẽ vượt quá con số 65536. Tuy nhiên trong bài toán của em, số phần tử tối đa trong nhóm là 6 phần tử, nhưng thực tế thì không phải lúc nào cũng có nhóm nào có 6 phần tử, họa hoằn lắm mới xuất hiện 1 nhóm như vậy thôi, đa phần các nhóm thường là 2-3 phần tử ^^, nên anh chị yên tâm là sẽ không bị tràn bộ nhớ , hihi. Em viết mãi thuật toán mà không được, khó quá đi mất, anh chị giúp em với nhé)
Xin góp một cách giải
Xin phép mượn file của bạn nguyentinhhn
Mã:
Public Sub PN()
Dim Vung, iCot, iHang, iTong, I, J, K, Hang, Heso, Vong, Sl
Set Vung = [a1].CurrentRegion
iCot = [j2].End(xlToLeft).Column:  iHang = Vung.Rows.Count - 1:   Heso = 1
    For I = 1 To iCot
       Set Hang = Range(Cells(2, I), Cells(9, I).End(xlUp))
        Heso = Heso * Hang.Rows.Count
    Next I
        Vong = 1: Sl = Heso
        For I = 1 To iCot
            Set Hang = Range(Cells(2, I), Cells(9, I).End(xlUp))
            Heso = Heso / Hang.Rows.Count
            For K = 1 To Vong
                For J = 1 To Hang.Rows.Count
                    Cells(10000, 10 + I).End(xlUp)(2).Resize(Heso) = Hang(J)
                Next J
            Next K
                Vong = Vong * Hang.Rows.Count
        Next I
        MsgBox "So luong liêt kê: " & Sl
End Sub
Thân
 

File đính kèm

Upvote 0
Tuyệt vời! Cám ơn anh concogia, tránh được thuật toán đệ qui.
thực sự code của anh concogia ngắn hơn, nhưng em không thể chỉnh được code để đáp án tổ hợp được ghi bắt đầu ở ô B15 trở đi, hjc.
Code của anh nguyentinhhn, em đã sửa và cho nó hiển thị được theo ý của em, hihi, cảm ơn anh nhiều ^^
 
Upvote 0
Code của cò già chạy nhanh gấp 3 lần, do đó bạn nên dùng code cò già. Chỉ cần sửa:

Cells(10000, 10 + i).End(xlUp)(2).Resize(Heso) = Hang(J)
thành

Cells(10000, 1 + i).End(xlUp)(2).Resize(Heso) = Hang(J)

sẽ bắt đầu từ cột B.

Còn dòng 15, bạn cứ để dòng 14 là tiêu đề, nó sẽ tự hiểu.
 
Upvote 0
Upvote 0
vâng, em cảm ơn anh, em đã sửa và thấy chạy đúng ý mình rồi. Tuy nhiên em chưa hiểu lắm, tại sao lại phải viết vô dòng 14 để chặn? hjc
Cells(10000, 1 + i).End(xlUp)(2).Resize(Heso) = Hang(J)
Cells(10000, 1 + i) : chọn cell (1000,1 +I) ==>nếu I=1 tức chọn cell (1000,2) ==> cell B1000
End(xlUp): chạy từ cell B1000 ngược về đầu bảng tính, khi gặp cell có dữ liệu thì "xì tốp hia"
(2): Ngay cell đang "xì tốp" nhảy xuống 1 hàng
Vì vậy muốn kết quả thể hiện ở B15 thì B14 phải có dữ liệu để code chạy từ B1000 lên tới B14 thì đứng lại rồi nhảy xuống B15 gán kết quả (chứ nếu B14 không có dữ liệu thì nó chạy "tuốt tuồn tuột" lên khu vực đề bài của bạn luôn á)
Vì bạn nói số phần tử trong mỗi cột không nhiều nên mình áp dụng cách gán trực tiếp lên sheet
Thân
 
Upvote 0
Logic lần 2

Lần trước với một bài tổ hợp khá phức tạp và không ai công phá nổi.
Sau một thời gian, hôm nay kieunhu ra một bài tập khác dễ thở hơn đối với mọi người.

http://www.mediafire.com/?xl4j8pab0d6t8ue

Dữ liệu có sẵn ở sheet 1 và sheet 2.
Dữ liệu ở sheet 1 bắt đầu từ dòng 14 trở xuống.
Dữ liệu ở sheet 2 được viết từ dòng 2 trở xuống.

Mục đích:
Cần xử lý dữ liệu ở sheet 1. Trong hàng nào tồn tại hai giá trị có class bằng nhau thì hàng đó sẽ bị bôi đen.
Ví dụ : Hàng 14 bị bôi đen vì A1 và B1 có class bằng nhau và bằng 1 (xem sheet 2 để thấy thông tin)
( thông tin class được viết ở sheet 2, từ dòng 2 trở xuống, số phần tử có class bằng nhau có thể nhiều hơn hai phần tử, ví dụ A1, B2,D1 (3 phần tử) cùng có class là 5. Trong file ví dụ này mình cho tương đối đơn giản.)

Thời hạn: Đến hết 10h ngày 2.4.2011
Giải thưởng cho người nào gửi đáp án viết bằng VBA sớm nhất, upload lên forum hoặc gửi thẳng vào mail:
hoanganh912@gmail.com

Nếu upload đáp án lên forum cần để lại địa chỉ mail để nhận giải thưởng.
Để nâng cao không khí tham gia góp vui không thể thiếu phần giải thưởng.
Giải thưởng là một thẻ nạp vina, mobi...(tùy theo yêu cầu của người giải đúng sớm nhất) trị giá 100k.
 
Lần chỉnh sửa cuối:
Upvote 0
Nếu được giải rủ ConCoGia đi nhậu chơi!

PHP:
Option Explicit
Sub ToMauDong()
 Dim Cls As Range, Rng As Range
 Dim StrC As String
 ReDim GPE1(1 To 3) As String:      ReDim GPE2(1 To 3) As String
 Dim Jj As Byte, Ww As Byte
  
 GPE1(1) = "A1":                         GPE2(1) = "B1"
 GPE1(2) = "A1":                         GPE2(2) = "C1"
 GPE1(3) = "B1":                         GPE2(3) = "D2"
 Set Rng = Range([A1].End(xlDown), [A65500].End(xlUp))
 For Each Cls In Rng
    With Cls
        StrC = .Value & .Offset(, 1).Value & .Offset(, 2).Value & .Offset(, 3).Value
    End With
    For Jj = 1 To 3
        If InStr(StrC, GPE1(Jj)) Then
            For Ww = 1 To 3
                If InStr(StrC, GPE2(Ww)) Then
                    Cls.Resize(, Month(Date)).Interior.ColorIndex = 33 + Month(Date)
                End If
            Next Ww
        End If
    Next Jj
 Next Cls
End Sub
 
Upvote 0
Code của bạn chạy chưa chính xác:
-Yếu tố quan trọng nhất chưa đạt được: khi dữ liệu về class được cập nhật thì code trên không còn đúng.
Mã:
 GPE1
Mã:
[COLOR=#007700]([/COLOR][COLOR=#0000bb]1[/COLOR][COLOR=#007700]) = [/COLOR][COLOR=#dd0000]"A1"[/COLOR][COLOR=#007700]:                         [/COLOR][COLOR=#0000bb]GPE2[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000bb]1[/COLOR][COLOR=#007700]) = [/COLOR][COLOR=#dd0000]"B1"
 [/COLOR][COLOR=#0000bb]GPE1[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000bb]2[/COLOR][COLOR=#007700]) = [/COLOR][COLOR=#dd0000]"A1"[/COLOR][COLOR=#007700]:                         [/COLOR][COLOR=#0000bb]GPE2[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000bb]2[/COLOR][COLOR=#007700]) = [/COLOR][COLOR=#dd0000]"C1"
 [/COLOR][COLOR=#0000bb]GPE1[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000bb]3[/COLOR][COLOR=#007700]) = [/COLOR][COLOR=#dd0000]"B1"[/COLOR][COLOR=#007700]:                         [/COLOR][COLOR=#0000bb]GPE2[/COLOR][COLOR=#007700]([/COLOR][COLOR=#0000bb]3[/COLOR][COLOR=#007700]) = [/COLOR][COLOR=#dd0000]"D2"[/COLOR]
Mã:
Việc gán như trên mang tính cố định, yếu tố "động" đã mất.
Trong bài toán này, dữ liệu ở sheet1 (cần xử lý) là dữ liệu cố định. Chương trình tham chiếu thông tin class ở sheet 2 để tô màu trên sheet 1. Thông tin về class được viết liền mạch, tức là nếu hai phần tử ( hoặc nhiều phần tử) có class giống nhau, chúng sẽ được viết trên các hàng liên tiếp. Ví dụ:

Phần tử ;Class
A1 ; 1
B1 ;1
C2; 1
D1 ; 2
A2 ; 2

Như vậy có thể thấy, ở sheet 1, cứ hàng nào xuất hiện A1 và B1 thì hàng đó sẽ bị bôi đen; hàng nào có A1, C2 thì hàng đó sẽ bị bôi đen; hàng nào có B1 và C2 thì hàng đó sẽ bị bôi đen; hàng nào có D1 và A2 thì hàng đó sẽ bị bôi đen.

-Code của bạn chạy chưa chính xác khi nó bôi màu dòng 21. Rõ ràng dòng này không vi phạm qui tắc vì vậy nó không bị bôi màu.

Cảm ơn bạn đã tham gia góp vui, chúc bạn tìm được giải pháp tốt hơn để ẵm giải thưởng :)

Chú ý: Khi bạn đưa đáp án lên forum bạn cần để lại địa chỉ mail để tiện liên lạc khi trao giải thưởng ( nếu bạn trúng giải)
 
Upvote 0
Viết chơi thôi chứ giải thưởng thì không ham.
PHP:
Sub GPE()
    Dim Dic, Cll As Range, Cll1 As Range, Cll2 As Range, Rng As Range, VT As Long
    Set Dic = CreateObject("Scripting.Dictionary")
    For Each Cll In Sheet2.Range(Sheet2.[A2], Sheet2.[A65536].End(xlUp))
        If Not Dic.Exists(Cll.Value) Then
            Dic.Add Cll.Value, vbBack & Cll.Offset(, 1).Value & vbBack
        Else
            Dic.Item(Cll.Value) = Dic.Item(Cll.Value) & Cll.Offset(, 1).Value & vbBack
        End If
    Next
    Set Rng = Sheet1.Range(Sheet1.[A14], Sheet1.[A65536].End(xlUp))
    Rng.EntireRow.Interior.Pattern = xlNone
    For Each Cll In Rng
        For Each Cll1 In Sheet1.Range(Cll, Sheet1.Cells(Cll.Row, "IV").End(xlToLeft).Offset(, -1))
            For Each Cll2 In Sheet1.Range(Cll1.Offset(, 1), Sheet1.Cells(Cll.Row, "IV").End(xlToLeft))
                VT = 0
                If Dic.Exists(Cll1.Value) And Dic.Exists(Cll2.Value) Then
                    For i = 1 To Len(Dic.Item(Cll1.Value)) - (Len(Replace(Dic.Item(Cll1.Value), vbBack, "")) + 1)
                        VT = InStr(VT + 1, Dic.Item(Cll1.Value), vbBack)
                        If InStr(Dic.Item(Cll2.Value), Mid(Dic.Item(Cll1.Value), VT, InStr(VT + 1, Dic.Item(Cll1.Value), vbBack) - VT + 1)) > 0 Then
                            Cll.EntireRow.Interior.Color = 65535
                            GoTo NextCll
                        End If
                    Next
                End If
            Next
        Next
NextCll:
    Next
End Sub
P/S: Không biết đây có phải là câu đố hay không???
 

File đính kèm

Lần chỉnh sửa cuối:
Upvote 0
Code của bạn huthang_bd giải hoàn toàn chính xác và là người giải đúng đầu tiên, thời hạn đưa ra đáp án nằm trong thời hạn cuộc chơi, hợp lệ. Tuy nhiên bạn đã nói:
Viết chơi thôi chứ giải thưởng thì không ham.
Vì vậy giải thưởng lần này sẽ được giữ lại làm giải thưởng cho các cuộc chơi sau.
Tuy nhiên vẫn hoan nghênh với những người yêu thích giải thuật và muốn khẳng định bản thân bằng những giải thuật chạy nhanh hơn.
Một lần nữa, cảm ơn hai bạn HYen17huuthang_bd đã tham gia cuộc chơi lần này.
______________________________________
Vì đã xuất hiện người đầu tiên giải thành công nên bài toán chỉ còn mang tính chất thảo luận. Vì vậy mình xin được góp vui bằng một giải thuật khác cũng cho lời giải chính xác bài toán này.
Code trên của bạn huuthang_hd sử dụng một số lệnh cao cấp quá, mình không hiểu.
Ví dụ:
Mã:
[COLOR=#000000][COLOR=#0000bb]Set Dic [/COLOR][COLOR=#007700]= [/COLOR][COLOR=#0000bb]CreateObject[/COLOR][COLOR=#007700]([/COLOR][COLOR=#dd0000]"Scripting.Dictionary"[/COLOR][COLOR=#007700])
[/COLOR][/COLOR]
Ở đây xin nêu ra một cách giải sử dụng hoàn toàn các lệnh logic thông thường.

Mã:
Sub tomau()
Dim i As Long
Dim j As Long
Dim s1 As String
Dim s2 As String
For i = 2 To 65535 Step 1
If Sheet2.Range("A" & i).Value = "" Then Exit For
[COLOR=blue]' Lệnh if ở trên nhằm mục đích thoát ra khỏi vòng for khi biến i chạy vượt quá ra khỏi vùng data[/COLOR]
 For j = i + 1 To 65536 Step 1
  If Sheet2.Range("A" & j).Value = "" Then Exit For
[COLOR=blue]' Lệnh if ở trên nhằm mục đích thoát ra khỏi vòng for khi biến j chạy vượt quá ra khỏi vùng data[/COLOR]
  If Sheet2.Range("B" & i).Value = Sheet2.Range("B" & j).Value Then
     s1 = Sheet2.Range("A" & i)
     s2 = Sheet2.Range("A" & j)
     Call thucthi(s1, s2)
  End If
  Next
Next
[COLOR=blue]' Hai lệnh for chạy song song thực chất là quét hết các phần tử có class bằng nhau, hễ tìm thấy một cặp phần tử có class bằng nhau
' Khi đó ta gán s1 và s2 nhận giá trị là cặp phần tử có class bằng nhau. Thủ tục thực thi sẽ tìm các dòng có chứa phần tử là s1 và s2 để tô màu[/COLOR]
End Sub
Sub thucthi(s1 As String, s2 As String)
Dim i As Long
Dim j As Long
Dim X As Boolean
Dim Y As Boolean
For i = 14 To 65535 Step 1
If Range("A" & i) = "" Then Exit For
X = False
Y = False
 For j = 0 To 255 Step 1
 If Range("A" & i).Offset(, j) = "" Then Exit For
  If Range("A" & i).Offset(, j).Value = s1 Then X = True
  If Range("A" & i).Offset(, j).Value = s2 Then Y = True
  Next
  If X = True And Y = True Then Rows(i).Interior.ColorIndex = 15
  
Next
 
End Sub
 
Lần chỉnh sửa cuối:
Upvote 0
Đề tài này có lẽ đã khá lâu rồi ko có ai để ý đến; Hôm nay mình có 1 bài toán muốn nhờ các bạn cao thủ giải giúp; Đề bài như sau: Cho 1 dãy các số thập phân, vd : 1,87; 1,1 ; 1,45; 1,67; 2,34; 1,1; 2,05; 1,87;2,08 ;.....dãy số này gồm n số, có giá trị sẽ lặp lại nhiều lần; Yêu cầu đặt ra là đưa ra 1 dãy số con của dãy số đã cho, nhằm thỏa mãn đk tổng các số thuộc dãy số con < 6 và tiến gần đến 6 nhất, vd : 1,1 + 1,45 + .....= 5,86 và 1,67 + 2,34 + ... = 5,90 thì ta sẽ chọn lấy 5,90, đề bài này mình đã cố gắng tìm lời giải mà đành bó tay; hy vọng sớm có cao thủ giúp mình giải quyết bài toán này, Thanks
 
Upvote 0

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

Back
Top Bottom