Board logo

標題: [發問] 請教3位數排列組合 [打印本頁]
作者: eric7765    時間: 2019-2-20 13:15     標題: 請教3位數排列組合

想請教前輩們
是否有公式或是用vba的方式
可以讓我在A欄中填入3個數字 可以自動在D欄中排列出各種組合並把編號帶入
[attach]30114[/attach][attach]30114[/attach][attach]30114[/attach]
作者: stillfish00    時間: 2019-2-21 13:45

本帖最後由 stillfish00 於 2019-2-21 13:53 編輯

回復 1# eric7765
任意位數排列
  1. Sub Solution()
  2.     Range(Cells(2, "D"), Cells(Rows.Count, "E")).ClearContents  ' Clear result
  3.     If Cells(Rows.Count, "A").End(xlUp).Row < 2 Then Exit Sub   ' Exit if no input
  4.     Dim text As String, id, r
  5.     r = 1
  6.     For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
  7.         text = Cells(i, "A").text
  8.         id = Cells(i, "B").Value
  9.         If Len(text) > 0 Then
  10.             For Each s In GetAllPermutation(text)
  11.                 r = r + 1
  12.                 Cells(r, "D").Value = s
  13.                 Cells(r, "E").Value = id
  14.             Next
  15.         End If
  16.     Next
  17. End Sub
複製代碼
  1. Function GetAllPermutation(ansi_str As String)
  2.     Dim ans: Set ans = CreateObject("scripting.dictionary")
  3.     Dim ch, new_ans
  4.     ans("") = 0
  5.     For i = 1 To Len(ansi_str)
  6.         ch = Mid(ansi_str, i, 1)
  7.         Set new_ans = CreateObject("scripting.dictionary")
  8.         For Each s In ans.keys()
  9.             For j = 0 To Len(s)
  10.                 new_ans(Left(s, j) & ch & Mid(s, j + 1)) = 0
  11.             Next
  12.         Next
  13.         Set ans = new_ans
  14.     Next
  15.     GetAllPermutation = ans.keys()
  16. End Function
複製代碼
作者: 准提部林    時間: 2019-2-21 15:29

D2:
=TEXT(SUM((0&MID(INDEX(A:A,INT(ROW(A6)/6)+1),MID({112233,231312,323121},MOD(ROW(A6),6)+1,1),1))*{100,10,1}),"000;;")

E2:
=INDEX(B:B,INT(ROW(A6)/6)+1)&""
作者: eric7765    時間: 2019-2-22 16:23

回復 3# 准提部林


    感謝大大 但有個小問題  可以排除重複的嗎?  比如 366 如果不重複 只會有3種組合 但是照這個公式 會排成6個組合
作者: eric7765    時間: 2019-2-22 16:27

回復 2# stillfish00
謝謝s大  對程式方面不熟悉 我貼上 它顯示 沒有定義sub 我附上檔案 可以麻煩 s大幫我看看嗎 感謝

[attach]30131[/attach]
作者: eric7765    時間: 2019-2-22 20:57

回復 2# stillfish00


    感謝s大 您提供的答案 完全符合我需要的 非常感謝
作者: eric7765    時間: 2019-2-27 13:29

回復 2# stillfish00

s大~非常感謝您幫忙解決上次的難題   如果改成 數字後面有+號再排列  或者是 在C欄中 如果有任意字再進行排列的話  這樣可行嗎?  麻煩大神有空時能指導一下 感激不盡
[attach]30145[/attach]

[attach]30146[/attach]
作者: ML089    時間: 2019-2-27 18:52

回復 7# eric7765


    + 改為 C欄 為 "P"
  1. Sub 排列3()
  2.     Range("D2:E999").ClearContents
  3.     j = 1
  4.     For i = 2 To [a65536].End(xlUp).Row
  5.         If Cells(i, "C").Value = "P" Then
  6.             'For Each k In Array(123, 132, 213, 231, 312, 321)
  7.             For k = 100 To 999
  8.                     a = Cells(i, "A")
  9.                     xA = 7 ^ Mid(a, 1, 1) + 7 ^ Mid(a, 2, 1) + 7 ^ Mid(a, 3, 1)
  10.                     xK = 7 ^ Mid(k, 1, 1) + 7 ^ Mid(k, 2, 1) + 7 ^ Mid(k, 3, 1)
  11.                     If xA = xK Then
  12.                         j = j + 1
  13.                         Cells(j, "D") = k
  14.                         Cells(j, "E") = Cells(i, "B")
  15.                     End If
  16.             Next k
  17.         Else
  18.             j = j + 1
  19.             Cells(j, "D") = Cells(i, "A")
  20.             Cells(j, "E") = Cells(i, "B")
  21.         End If
  22.     Next i
  23. End Sub
複製代碼
作者: eric7765    時間: 2019-2-27 19:10

回復 8# ML089
感謝麻辣前輩的解答~已成功
作者: eric7765    時間: 2019-3-4 14:26

本帖最後由 eric7765 於 2019-3-4 14:27 編輯

回復 8# ML089
M大 抱歉 這兩周用起來發現 這程式運行 如果遇到數字裡面有"0"排列出來的組合都會缺少 能麻煩前輩幫忙看看嗎?
[attach]30165[/attach]
作者: ML089    時間: 2019-3-4 16:34

回復 10# eric7765

試試看看，由000~999

Sub 排列3()
    Range("D2:E999").ClearContents
    j = 1
    For i = 2 To [a65536].End(xlUp).Row
        If Cells(i, "C").Value = "P" Then
            'For Each k In Array(123, 132, 213, 231, 312, 321)
            For k = 1000 To 1999
                    a = Cells(i, "A")
                    xA = 7 ^ Mid(a, 1, 1) + 7 ^ Mid(a, 2, 1) + 7 ^ Mid(a, 3, 1)
                    xK = 7 ^ Mid(k, 2, 1) + 7 ^ Mid(k, 3, 1) + 7 ^ Mid(k, 4, 1)
                    If xA = xK Then
                        j = j + 1
                        Cells(j, "D") = Mid(k, 2, 3)
                        Cells(j, "E") = Cells(i, "B")
                    End If
            Next k
        Else
            j = j + 1
            Cells(j, "D") = Cells(i, "A")
            Cells(j, "E") = Cells(i, "B")
        End If
    Next i
End Sub
作者: eric7765    時間: 2019-3-4 18:08

回復 11# ML089
m大 剛剛測試的結果 只要開頭是0 ex:001 023 013 就會出現格式不符
[attach]30166[/attach]
作者: eric7765    時間: 2019-3-4 18:16

回復 11# ML089
[attach]30168[/attach]
作者: ML089    時間: 2019-3-4 21:12

回復 13# eric7765

023 其實是 23會有錯誤
要輸入 '023
作者: stillfish00    時間: 2019-3-7 17:24

回復 7# eric7765
C欄中 如果有任意字再進行排列
  1. Sub Solution()
  2.     Range(Cells(2, "D"), Cells(Rows.Count, "E")).ClearContents  ' Clear result
  3.     If Cells(Rows.Count, "A").End(xlUp).Row < 2 Then Exit Sub   ' Exit if no input
  4.     Dim text As String, id, r
  5.     r = 1
  6.     For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
  7.         text = Cells(i, "A").text
  8.         id = Cells(i, "B").Value
  9.         If Len(text) > 0 Then
  10.             If Len(Cells(i, "C").text) > 0 Then
  11.                 For Each s In GetAllPermutation(text)
  12.                     r = r + 1
  13.                     Cells(r, "D").Value = s
  14.                     Cells(r, "E").Value = id
  15.                 Next
  16.             Else
  17.                     r = r + 1
  18.                     Cells(r, "D").Value = text
  19.                     Cells(r, "E").Value = id
  20.             End If
  21.         End If
  22.     Next
  23. End Sub
  24. Function GetAllPermutation(ansi_str As String)
  25.     Dim ans: Set ans = CreateObject("scripting.dictionary")
  26.     Dim ch, new_ans
  27.     ans("") = 0
  28.     For i = 1 To Len(ansi_str)
  29.         ch = Mid(ansi_str, i, 1)
  30.         Set new_ans = CreateObject("scripting.dictionary")
  31.         For Each s In ans.keys()
  32.             For j = 0 To Len(s)
  33.                 new_ans(Left(s, j) & ch & Mid(s, j + 1)) = 0
  34.             Next
  35.         Next
  36.         Set ans = new_ans
  37.     Next
  38.     GetAllPermutation = ans.keys()
  39. End Function
複製代碼




歡迎光臨 麻辣家族討論版版 (http://forum.twbts.com/)