帖子: 79
主題: 19
精華: 0
積分: 87
點名: 0
作業系統: win7
軟體版本: 旗艦版
閱讀權限: 20
註冊時間: 2017-3-22
最後登錄: 2024-3-12

論壇贊助勳章

1^# 跳轉到 » 正序看帖

打印

字體大小: tT

發表於 2019-2-20 13:15 | 只看該作者

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

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

樓主熱帖

stillfish00

大學生 Rank: 4

帖子: 1018
主題: 15
精華: 0
積分: 1058
點名: 0
作業系統: win7 32bit
軟體版本: Office 2016 64-bit
閱讀權限: 50
性別: 男
來自: 桃園
註冊時間: 2012-5-9
最後登錄: 2022-9-28

15^#

發表於 2019-3-7 17:24 | 只看該作者

回復 7# eric7765
C欄中如果有任意字再進行排列

Sub Solution()
Range(Cells(2, "D"), Cells(Rows.Count, "E")).ClearContents ' Clear result
If Cells(Rows.Count, "A").End(xlUp).Row < 2 Then Exit Sub ' Exit if no input
Dim text As String, id, r
r = 1
For i = 2 To Cells(Rows.Count, "A").End(xlUp).Row
text = Cells(i, "A").text
id = Cells(i, "B").Value
If Len(text) > 0 Then
If Len(Cells(i, "C").text) > 0 Then
For Each s In GetAllPermutation(text)
r = r + 1
Cells(r, "D").Value = s
Cells(r, "E").Value = id
Next
Else
r = r + 1
Cells(r, "D").Value = text
Cells(r, "E").Value = id
End If
End If
Next
End Sub
Function GetAllPermutation(ansi_str As String)
Dim ans: Set ans = CreateObject("scripting.dictionary")
Dim ch, new_ans
ans("") = 0
For i = 1 To Len(ansi_str)
ch = Mid(ansi_str, i, 1)
Set new_ans = CreateObject("scripting.dictionary")
For Each s In ans.keys()
For j = 0 To Len(s)
new_ans(Left(s, j) & ch & Mid(s, j + 1)) = 0
Next
Next
Set ans = new_ans
Next
GetAllPermutation = ans.keys()
End Function

複製代碼

表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

ML089

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2025
主題: 13
精華: 0
積分: 2053
點名: 0
作業系統: WIN7
軟體版本: Office2007
閱讀權限: 100
性別: 男
來自: 台北市
註冊時間: 2011-3-2
最後登錄: 2024-3-14

論壇榮譽勳章論壇贊助勳章熱烈參與勳章 2014馬年全勤獎章 2015羊年全勤獎章 2016猴年全勤獎章

14^#

發表於 2019-3-4 21:12 | 只看該作者

回復 13# eric7765

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

{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

eric7765

中學生 Rank: 2

帖子: 79
主題: 19
精華: 0
積分: 87
點名: 0
作業系統: win7
軟體版本: 旗艦版
閱讀權限: 20
註冊時間: 2017-3-22
最後登錄: 2024-3-12

論壇贊助勳章

13^#

發表於 2019-3-4 18:16 | 只看該作者

回復 11# ML089

TOP

eric7765

中學生 Rank: 2

帖子: 79
主題: 19
精華: 0
積分: 87
點名: 0
作業系統: win7
軟體版本: 旗艦版
閱讀權限: 20
註冊時間: 2017-3-22
最後登錄: 2024-3-12

論壇贊助勳章

12^#

發表於 2019-3-4 18:08 | 只看該作者

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

00錯.png (87.6 KB)

TOP

ML089

版主 Rank: 7 Rank: 7 Rank: 7

帖子: 2025
主題: 13
精華: 0
積分: 2053
點名: 0
作業系統: WIN7
軟體版本: Office2007
閱讀權限: 100
性別: 男
來自: 台北市
註冊時間: 2011-3-2
最後登錄: 2024-3-14

論壇榮譽勳章論壇贊助勳章熱烈參與勳章 2014馬年全勤獎章 2015羊年全勤獎章 2016猴年全勤獎章

11^#

發表於 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

{...} 表示需要用 CTRL+SHIFT+ENTER 三鍵輸入公式

TOP

eric7765