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

eric7765

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

下載 (20.99 KB)

2019-2-20 13:09

stillfish00

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

複製代碼

ML089

回復 13# eric7765

023 其實是 23會有錯誤
要輸入 '023

eric7765

回復 11# ML089

下載 (63.12 KB)

2019-3-4 18:16

eric7765

回復 11# ML089
m大 剛剛測試的結果 只要開頭是0 ex:001 023 013 就會出現格式不符

下載 (87.6 KB)

2019-3-4 18:06

ML089

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

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

下載 (58.39 KB)

2019-3-4 14:25

eric7765

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

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

回復 2# stillfish00

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

下載 (63.09 KB)

2019-2-27 13:24

排列.rar (15.7 KB)

下載次數: 5

2019-2-27 13:29