Hiển tất cả các kết quả của tổ hợp

Liên hệ QC

nhs243

Thành viên mới
Tham gia
13/5/11
Bài viết
33
Được thích
0
Như tiêu đề, để biết có bao nhiêu cách sắp xếp 1 số có 6 chữ số trong chuỗi từ 1 đến 6 thì có tổ hợp hoặc 6!=720 cách sắp xếp, vậy em muốn hiển thị ra tất cả 720 các kết quả này trong excel thì có cách nào hiển thị nhanh không ạ.
Em xin cảm ơn.
 
Như tiêu đề, để biết có bao nhiêu cách sắp xếp 1 số có 6 chữ số trong chuỗi từ 1 đến 6 thì có tổ hợp hoặc 6!=720 cách sắp xếp, vậy em muốn hiển thị ra tất cả 720 các kết quả này trong excel thì có cách nào hiển thị nhanh không ạ.
Em xin cảm ơn.
Nếu thế là hoán vị chứ đâu phải tổ hợp?

Tổ hợp chập k của n phần tử:
1524759415952.png

Tìm trên diễn đàn có nhiều bài rồi, hai ngày gần đây cũng có vài người hỏi liền...
 
Có vài cách. Và cách dễ nhất là xét từ 123456 (số nhỏ nhất) đến 654321 (số lớn nhất). Số nào không có đủ các chữ số thì loại.

Hàm xét đủ 6 chữ số dễ nhất là:
Function Xet6ChuSo(byval so As Long) As Boolean
Dim soStr As String, i As Integer
soStr = Cstr(so)
For i = 1 to 6
if InStr(soStr, Cstr(i)) < 1 Then Exit Function
Next i
Xet6ChuSo = True
End Function

Lú ý: tôi nói chuyện "dễ nhất" chứ khong phải "hiệu quả" nhất
 
Như tiêu đề, để biết có bao nhiêu cách sắp xếp 1 số có 6 chữ số trong chuỗi từ 1 đến 6 thì có tổ hợp hoặc 6!=720 cách sắp xếp, vậy em muốn hiển thị ra tất cả 720 các kết quả này trong excel thì có cách nào hiển thị nhanh không ạ.
Em xin cảm ơn.
Dùng VBA
Mã:
Sub GPE()
  Dim Arr As Variant, n, sR As Long
  sR = Range("A" & Rows.Count).End(xlUp).Row
  If sR > 1 Then Range("A2:X" & sR).ClearContents
  n = Range("C1").Value
  If TypeName(n) = "Double" Then
    If n < 2 Then Exit Sub Else n = Int(n)
    Arr = HoanVi(n)
    If UBound(Arr) > 1048574 Then sR = 1048574 Else sR = UBound(Arr)
    Range("A2").Resize(sR, n) = Arr
  End If
End Sub

Private Function HoanVi(ByVal S As Byte) As Variant
  If S < 2 Then Exit Function
  Dim Arr() As Integer, n As Double, q As Double, m As Double
  Dim i As Byte, j As Byte, k As Byte
  ReDim Arr(1 To WorksheetFunction.Fact(S), 1 To S)
  Arr(1, 1) = 1: n = 1
  For k = 2 To S
    n = n * k
    For m = 1 To n / k
        Arr(m, k) = k
    Next m
    q = m - 1
    For i = 1 To k - 1
        For m = 1 To n / k
            q = q + 1
            For j = 1 To k
                If j = i Then
                    Arr(q, j) = k
                ElseIf i < j Then
                        Arr(q, j) = Arr(m, j - 1)
                    Else
                        Arr(q, j) = Arr(m, j)
                End If
            Next j
        Next m
    Next i
  Next k
  HoanVi = Arr
  Erase Arr
End Function
 

File đính kèm

  • GPE_hv.xlsm
    19.5 KB · Đọc: 7
Như tiêu đề, để biết có bao nhiêu cách sắp xếp 1 số có 6 chữ số trong chuỗi từ 1 đến 6 thì có tổ hợp hoặc 6!=720 cách sắp xếp, vậy em muốn hiển thị ra tất cả 720 các kết quả này trong excel thì có cách nào hiển thị nhanh không ạ.
Em xin cảm ơn.
Bài toán hoán vị nó thế này đây:
Mã:
Private Function GetPermut(ByVal x As String, ByVal y As String, ByRef arr() As String)
  Dim i As Long, j As Long, idx  As Long
  Dim ret
  j = Len(y)
  If j < 2 Then
    On Error Resume Next
    idx = UBound(arr)
    On Error GoTo 0
    idx = idx + 1
    ReDim Preserve arr(1 To idx)
    arr(idx) = x & y
  Else
    For i = 1 To j
      ret = GetPermut(x & Mid(y, i, 1), Left(y, i - 1) & Right(y, j - i), arr)
    Next
  End If
  GetPermut = arr
End Function
Để thuận tiện cho việc sử dụng, viết thêm hàm người dùng nữa:
Mã:
Function Permu(ByVal text As String)
  Dim x As String, arr() As String
  Permu = GetPermut(x, text, arr())
End Function
Cuối cùng là áp dụng lấy kết quả ra bảng tính
Mã:
Sub Main()
  Dim text As String, arr
  Dim lR As Long
  text = "123456"
  arr = Permu(text)
  If IsArray(arr) Then
    ReDim aDes(1 To UBound(arr), 1 To 1)
    For lR = 1 To UBound(arr)
      aDes(lR, 1) = arr(lR)
    Next
    Range("A1").Resize(lR - 1) = aDes
  End If
End Sub
Ngoài ra có trường hợp chuỗi đầu vào là "1122" thì kết quả sẽ có nhiều phần tử trùng, khi ấy phải sửa lại hàm theo kiểu khác (ai có nhu cầu sẽ mần tiếp)
 

File đính kèm

  • GetPermutation.xlsm
    19.6 KB · Đọc: 4
Dùng VBA
Mã:
Sub GPE()
  Dim Arr As Variant, n, sR As Long
  sR = Range("A" & Rows.Count).End(xlUp).Row
  If sR > 1 Then Range("A2:X" & sR).ClearContents
  n = Range("C1").Value
  If TypeName(n) = "Double" Then
    If n < 2 Then Exit Sub Else n = Int(n)
    Arr = HoanVi(n)
    If UBound(Arr) > 1048574 Then sR = 1048574 Else sR = UBound(Arr)
    Range("A2").Resize(sR, n) = Arr
  End If
End Sub

Private Function HoanVi(ByVal S As Byte) As Variant
  If S < 2 Then Exit Function
  Dim Arr() As Integer, n As Double, q As Double, m As Double
  Dim i As Byte, j As Byte, k As Byte
  ReDim Arr(1 To WorksheetFunction.Fact(S), 1 To S)
  Arr(1, 1) = 1: n = 1
  For k = 2 To S
    n = n * k
    For m = 1 To n / k
        Arr(m, k) = k
    Next m
    q = m - 1
    For i = 1 To k - 1
        For m = 1 To n / k
            q = q + 1
            For j = 1 To k
                If j = i Then
                    Arr(q, j) = k
                ElseIf i < j Then
                        Arr(q, j) = Arr(m, j - 1)
                    Else
                        Arr(q, j) = Arr(m, j)
                End If
            Next j
        Next m
    Next i
  Next k
  HoanVi = Arr
  Erase Arr
End Function
Đùa chắc, bạn ý kêu là 6 thì bạn cho 5 cái vòng lặp for, tẹo nữa bạn ý kêu là 10 thì tính sao?
 
Dùng VBA
Mã:
Sub GPE()
  Dim Arr As Variant, n, sR As Long
  sR = Range("A" & Rows.Count).End(xlUp).Row
  If sR > 1 Then Range("A2:X" & sR).ClearContents
  n = Range("C1").Value
  If TypeName(n) = "Double" Then
    If n < 2 Then Exit Sub Else n = Int(n)
    Arr = HoanVi(n)
    If UBound(Arr) > 1048574 Then sR = 1048574 Else sR = UBound(Arr)
    Range("A2").Resize(sR, n) = Arr
  End If
End Sub

Private Function HoanVi(ByVal S As Byte) As Variant
  If S < 2 Then Exit Function
  Dim Arr() As Integer, n As Double, q As Double, m As Double
  Dim i As Byte, j As Byte, k As Byte
  ReDim Arr(1 To WorksheetFunction.Fact(S), 1 To S)
  Arr(1, 1) = 1: n = 1
  For k = 2 To S
    n = n * k
    For m = 1 To n / k
        Arr(m, k) = k
    Next m
    q = m - 1
    For i = 1 To k - 1
        For m = 1 To n / k
            q = q + 1
            For j = 1 To k
                If j = i Then
                    Arr(q, j) = k
                ElseIf i < j Then
                        Arr(q, j) = Arr(m, j - 1)
                    Else
                        Arr(q, j) = Arr(m, j)
                End If
            Next j
        Next m
    Next i
  Next k
  HoanVi = Arr
  Erase Arr
End Function
Nếu chuỗi tùy ý thì sao ta? Chẳng hạn "abcdef"
Phải hiểu hoán vị ở đây là: Ta cho trước 1 chuỗi hoặc 1 mảng. Giờ ta hoán vị vị trí các ký tự (hoặc hoán vị vị trí các phần tử trong mảng). Điều đó có nghĩa là chuỗi đầu vào là bất kỳ
 
Nếu chuỗi tùy ý thì sao ta? Chẳng hạn "abcdef"
Phải hiểu hoán vị ở đây là: Ta cho trước 1 chuỗi hoặc 1 mảng. Giờ ta hoán vị vị trí các ký tự (hoặc hoán vị vị trí các phần tử trong mảng). Điều đó có nghĩa là chuỗi đầu vào là bất kỳ
Nhiệm vụ Function xác định vị trí của từng phần tử, sub main sẽ có 2 vòng For theo dòng và cột để gán các các phần tử vào từng vị trí
 
Cụ thể là sao bạn viết tổng quát tôi tham khảo với
Bạn khéo đùa rồi, mình còn phải nhờ bạn góp ý nhiều
Mã:
Sub GPE()
  Dim Arr As Variant, Res As Variant, dArr As Variant, n, sR As Long, i As Long, j As Byte
  sR = Range("A" & Rows.Count).End(xlUp).Row
  If sR > 1 Then Range("A2:X" & sR).ClearContents
  n = Range("C1").Value
  If TypeName(n) = "Double" Then
    If n < 2 Then Exit Sub Else n = Int(n)
    Arr = HoanVi(n)
    If UBound(Arr) > 1048574 Then sR = 1048574 Else sR = UBound(Arr)
    dArr = Array("", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j")
    ReDim Res(1 To sR, 1 To n)
    For i = 1 To sR
      For j = 1 To n
        Res(i, j) = dArr(Arr(i, j))
      Next j
    Next i
    Range("A2").Resize(sR, n) = Res
  End If
End Sub

Nếu không muốn tạo thêm mảng Res thì khai báo lại Arr
Mã:
Sub GPE2()
  Dim Arr As Variant, dArr As Variant, n, sR As Long, i As Long, j As Byte
  sR = Range("A" & Rows.Count).End(xlUp).Row
  If sR > 1 Then Range("A2:X" & sR).ClearContents
  n = Range("C1").Value
  If TypeName(n) = "Double" Then
    If n < 2 Then Exit Sub Else n = Int(n)
    Arr = HoanVi2(n)
    If UBound(Arr) > 1048574 Then sR = 1048574 Else sR = UBound(Arr)
    dArr = Array("", "a", "b", "c", "d", "e", "f", "g", "h", "i", "j")
    For i = 1 To sR
      For j = 1 To n
        Arr(i, j) = dArr(Arr(i, j))
      Next j
    Next i
    Range("A2").Resize(sR, n) = Arr
  End If
End Sub

Private Function HoanVi2(ByVal S As Byte) As Variant
  If S < 2 Then Exit Function
  Dim Arr As Variant, n As Double, q As Double, m As Double
  Dim i As Byte, j As Byte, k As Byte
  ReDim Arr(1 To WorksheetFunction.Fact(S), 1 To S)
  Arr(1, 1) = 1: n = 1
  For k = 2 To S
    n = n * k
    For m = 1 To n / k
        Arr(m, k) = k
    Next m
    q = m - 1
    For i = 1 To k - 1
        For m = 1 To n / k
            q = q + 1
            For j = 1 To k
                If j = i Then
                    Arr(q, j) = k
                ElseIf i < j Then
                        Arr(q, j) = Arr(m, j - 1)
                    Else
                        Arr(q, j) = Arr(m, j)
                End If
            Next j
        Next m
    Next i
  Next k
  HoanVi2 = Arr
  Erase Arr
End Function
Sửa tên Function quên chỉnh trong code
 

File đính kèm

  • GPE_hv.xlsm
    20.4 KB · Đọc: 4
Lần chỉnh sửa cuối:
So sánh khập khiễng quá. Chim thì nhắm mắt tắt đèn cũng ra ngay, chả phải tìm lâu :D

Ở đây chỉ có 6 chim thôi, mò bờ mu cũng dễ.
(đúng ra thì dễ quá tôi tưởng không cần phải trưng cốt. Nhưng nếu không có cốt thì bị kết tội sì pem)

Sub MoBoMu()
Dim Mu(1 To 6 * 5 * 4 * 3 * 2) As String
Dim chim As Long, cnt As Integer
For chim = 123456 To 654321
If Xet6ChuSo(chim) Then
cnt = cnt + 1
Mu(cnt) = CStr(chim)
Cells(cnt, 1) = Mu(cnt)
End If
Next chim
End Sub

Function Xet6ChuSo(ByVal so As Long) As Boolean
Dim soStr As String, i As Integer
soStr = CStr(so)
For i = 1 To 6
If InStr(soStr, CStr(i)) < 1 Then Exit Function
Next i
Xet6ChuSo = True
End Function
 
Thớt này được ỉa mặt (1) không cho đùa. Vậy thì chỉ nói chuyện chim cốt (2) thôi:

Lúc làm bờ mu tế sống (3) thì công thức đã có sẵn để tính số kết quả. Ai hơi đâu vài ngàn kết quả phải rề điếm (4) mảng vài ngàn lần?
Vả lại, dùng ông ể rọ (5) để bắt lỗi chưa gán bộ nhớ mảng là cách đốt nhà để buộc lòi mặt chuột. Người ta có cách rờ rẫm con trỏ mảng để biết nó đã có chỗ chưa.

(1) ear marked, (2) trim code, (3) permutation, (4) redim, (5) on error: tiếng Tây chứ hỏng phải đồ bậy bạ đâu nhé. Tôi chỉ theo xu hướng viết kiểu trọ trẹ phiên âm thôi.
 
Nếu tôi không lầm thì code sau đây mới làm chóng mặt.

Nên test với chuỗi ít nhất 9 ký tự vì ít hơn không đáng, chưa kịp chớp mắt. Nếu máy khỏe thì test với chuỗi 10, 11 ký tự, tất nhiên khi này không nhập kết quả xuống sheet. Với những chuỗi dài thì khi có ~1 triệu kết quả thì đổ xuống sheet và xóa mảng kết quả rồi mới làm tiếp để đổ xuống cột "bên cạnh".

Theo qui tắc đặt tên procedure thì thấy ổn, Excel không lườm nguýt gì. Theo phép vua cũng thấy ổn. Không biết theo lệ làng tên có ổn không.

Mã:
Option Explicit

Sub mo_bo_mu_tim_chim_hai_canh_va_ca_chim_bon_canh(ByVal str_char As String, index As Long, Arr())
Dim k As Long, n As Long, m As Long
Dim firstChar  As String, currChar As String
    k = Len(str_char)
    If k = 1 Then
        index = index + 1
        Arr(index, 1) = str_char
    Else
        mo_bo_mu_tim_chim_hai_canh_va_ca_chim_bon_canh Mid(str_char, 2), index, Arr
        k = index
        firstChar = Mid(str_char, 1, 1)
        For m = 2 To Len(str_char)
            currChar = Mid(str_char, m, 1)
            For n = 1 To k
                index = index + 1
                Arr(index, 1) = currChar & Replace(Arr(n, 1), currChar, firstChar)
            Next n
        Next m
        For n = 1 To k
            Arr(n, 1) = firstChar & Arr(n, 1)
        Next n
    End If
End Sub

Sub GetPermutations(ByVal chars As String, Arr())
Dim index As Long
    ReDim Arr(1 To Application.WorksheetFunction.Fact(Len(chars)), 1 To 1)
    mo_bo_mu_tim_chim_hai_canh_va_ca_chim_bon_canh chars, index, Arr
End Sub

Sub test()
Dim Arr(), t, k As Long
    t = Timer
    GetPermutations "123456789", Arr

    Range("B1").Resize(UBound(Arr)).Value = Arr
    
    Debug.Print "batman1: " & Timer - t
End Sub
 
Phần này tôi viết để bàn về cách cốt. Bạn nào thích thì xem cho thật nhanh, khả năng nó có thể sẽ được xóa vì bàn chuyện ngoài lề.

Tự thuở xa xưa, các bậc trưởng thượng trên diễn đàn này đã quen với cách dùng "On Error..." để bẫy lỗi. Riết rồi 99% những người trên diễn đàn thấy nó bình thường. Ngay cả gần đây có một người nêu vấn đề này trong một cái thớt "Quai Ai Hết (Why I hate...)" nhưng chả ai buồn để ý.

Thực tế thì cách bẫy lỗi này cũng không hẳn sai. Nó là một đặc tính của Basic, được MS truyền qua VB, VBS và VBA. Chỉ là thời buổi công nghệ mới này nên chịu khó mỗi lúc dùng thì chú thích rằng mình cốt ý bẫy những lỗi gì. Nhất là các loại hàm để giành dùng trong thư viện. Về sau này, người debug code sẽ dễ thở hơn khi gặp trường hợp những lỗi không muốn bẫy.

Nói nôm na ra, thuật toán xét mảng chưa được gán bộ nhớ mà dùng On Error Resume Next là thuật toán thượng cổ. Bây giờ người ta dùng như thế này:

Sub t()
Dim a1(), a2()

For i = 1 To 10
If (Not a1) = -1 Then ' nếu a1 chưa có địa chỉ thì con trỏ là null, và not của nó là -1
' Not là toán tử sơ khai của VB, nó sẽ truy cập thẳng biến mà không qua phương thức mặc định
' không thể so sánh thẳng a1 với 0 bởi vì nó sẽ tìm qua phương thức mặc định

ReDim a1(1 To 1)
Else
ReDim a1(1 To UBound(a1) + i)
End If
Next i

ReDim a2(1 To (10 * 10 + 10) / 2) ' giản dị bằng công thức 1 + 2 + ... + n = (n^2 + n)/2

Debug.Print UBound(a1) = UBound(a2) ' kết quả là True
End Sub
 
Phần này tôi viết để bàn về cách cốt. Bạn nào thích thì xem cho thật nhanh, khả năng nó có thể sẽ được xóa vì bàn chuyện ngoài lề.
"Ngoài lề" nó là thế nào chắc không cần bàn?
Khẳng định với bạn rằng không thành viên BQT nào lại đi xóa những bài mang tính chuyên môn cao cả. Cho dù những bài chuyên môn cao ấy không liên quan đến nội dung topic đi nữa thì cùng lắm BQT sẽ cố gắng dời đến vị trị phù hợp.
Mọi kiến thức mà bạn và mọi người chia sẻ ở đây đều được trân trọng!
Cũng nói thêm rằng: Với những bài viết mang tính chuyên môn cao thì đừng nói là BQT, kể cả bạn cũng không được quyền xóa bài của chính mình, vì khi ấy bài viết đã trở thành tài nguyên của diễn đàn rồi
 
...
Khẳng định với bạn rằng không thành viên BQT nào lại đi xóa những bài mang tính chuyên môn cao cả. ...

"chuyên môn cao" mang tính chất tương đối và đầy chủ quan. Lấy cái gì để đo chuyên môn cao? nếu không phải là ý kiến của thành viên BQT?

"khẳng định" mang tính chất tuyệt đối. Tuyệt đói khó đi chung với tương đối. (đương nhiên từ "khó đi chung" toi dùng trên cũng là tương đối)
 
"chuyên môn cao" mang tính chất tương đối và đầy chủ quan. Lấy cái gì để đo chuyên môn cao? nếu không phải là ý kiến của thành viên BQT?
Điều đó là đương nhiên rồi. Bởi như tôi đã nói ở trên: bài viết của bạn sẽ là tài nguyên của diễn đàn. Đã là tài sản đương nhiên chúng tôi có quyền phân loại cái nào tốt cần để lại và cái nào xấu cần bỏ đi (giống nhà bạn thôi)
 
Nhìn lại code thấy dài, xử lý từng ký tự và biến mảng nhiều cột kích thước lớn, chỉnh lại code cho gọn và tăng tốc xử lý
Mã:
Sub GPE()
  Dim Arr(), Str As String
  t = Timer
  Str = "123456789"
  HoanVi Str, Arr
  [a1].Resize(UBound(Arr)) = Arr
  [b1] = Timer - t
End Sub

Private Sub HoanVi(ByVal Str As String, Arr())
  Dim n As Long, q As Long, m As Long
  Dim i As Byte, j As Byte, k As Byte, S As Byte
  S = Len(Str)
  ReDim Arr(1 To WorksheetFunction.Fact(S), 1 To 1)
  Arr(1, 1) = Str:  n = 1
  For k = 2 To S
    q = n:    n = n * k
    For i = 1 To k - 1
      For m = 1 To n \ k
        q = q + 1
        Arr(q, 1) = Str
        Mid(Arr(q, 1), i, 1) = Mid(Str, k, 1)
        Mid(Arr(q, 1), i + 1, k - i) = Mid(Arr(m, 1), i, k - i)
        If i > 1 Then Mid(Arr(q, 1), 1, i - 1) = Mid(Arr(m, 1), 1, i - 1)
      Next m
    Next i
  Next k
End Sub
 

File đính kèm

  • GPE_hv.xlsm
    19.4 KB · Đọc: 5
@HieuCD:

Theo lý thuyết thì lời giải chỉ cần mảng 1 chiều. Có lẽ vì lý do cần chuyển kết quả lên worksheet mà bạn phải dùng mảng 2 chiều. Điều này tuy hiệu quả nhưng rất gượng ép và làm giảm tính chất độc lập của cái hàm chính - tức là cái hàm tính tổ hợp của bạn. Nói cách khác, người đọc code hàm HoanVi sẽ thắc mắc không hiểu tại sao trong hàm lại dùng mảng 2 chiều; mãi đến lúc đọc code hàm GPE mới hiểu.

Nếu là tôi thì tôi cho hàm chính chạy trên mảng 1 chiều. Khi cần hiển thị lên worksheet thì chuyển qua mảng 2 chiều.
Dùng code sửa từ code nguyên thủy của bạn thì thời gian chuyển qua mảng 2 chiều chỉ bằng 1/4 thời gian đưa lên bảng tính. Tổng cộng lại, kết quả chỉ chậm hơn code nguyên thủy khoảng 10%.

Mã:
Sub GPE()
  Dim Arr(), Str As String
  t = Timer
  Str = "123456789"
  HoanVi Str, Arr
  [c1] = Timer - t ' cái này mới là thời gian tính thực thụ
  Dim Arr2, i As Long, sd As Long
  sd = UBound(Arr)
  ReDim Arr2(1 To sd, 1 To 1)
  For i = 1 To sd
  Arr2(i, 1) = Arr(i)
  Next i
  [a1].Resize(sd) = Arr2
  [b1] = Timer - t
End Sub

Private Sub HoanVi(ByVal Str As String, Arr())
  Dim n As Long, q As Long, m As Long
  Dim i As Byte, j As Byte, k As Byte, S As Byte
  S = Len(Str)
  ReDim Arr(1 To WorksheetFunction.Fact(S))
  Arr(1) = Str:  n = 1
  For k = 2 To S
    q = n:    n = n * k
    For i = 1 To k - 1
      For m = 1 To n \ k
        q = q + 1
        Arr(q) = Str
        Mid(Arr(q), i, 1) = Mid(Str, k, 1)
        Mid(Arr(q), i + 1, k - i) = Mid(Arr(m), i, k - i)
        If i > 1 Then Mid(Arr(q), 1, i - 1) = Mid(Arr(m), 1, i - 1)
      Next m
    Next i
  Next k
End Sub
 
Web KT
Back
Top Bottom