[發問] 請教3位數排列組合

eric7765

想請教前輩們
是否有公式或是用vba的方式
可以讓我在A欄中填入3個數字 可以自動在D欄中排列出各種組合並把編號帶入

下載 (20.99 KB)

2019-2-20 13:09

stillfish00

回復 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

複製代碼

准提部林

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

回復 3# 准提部林


    感謝大大 但有個小問題  可以排除重複的嗎?  比如 366 如果不重複 只會有3種組合 但是照這個公式 會排成6個組合

eric7765

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

3位數排列組合.rar (15.96 KB)

下載次數: 3

2019-2-22 16:26

eric7765

回復 2# stillfish00


    感謝s大 您提供的答案 完全符合我需要的 非常感謝

eric7765

回復 2# stillfish00

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

下載 (63.09 KB)

2019-2-27 13:24

排列.rar (15.7 KB)

下載次數: 5

2019-2-27 13:29

ML089

回復 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

回復 8# ML089
感謝麻辣前輩的解答~已成功

eric7765

回復 8# ML089
M大 抱歉 這兩周用起來發現 這程式運行 如果遇到數字裡面有"0"排列出來的組合都會缺少 能麻煩前輩幫忙看看嗎?

下載 (58.39 KB)

2019-3-4 14:25