返回列表 上一主題 發帖

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

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
1# 跳轉到 »
發表於 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
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

stillfish00

帖子
1018 
主題
15 
精華
0 
積分
1058 
點名
0  
作業系統
win7 32bit 
軟體版本
Office 2016 64-bit 
閱讀權限
50 
性別
男 
來自
桃園 
註冊時間
2012-5-9 
最後登錄
2022-9-28 
2#
發表於 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
複製代碼
表達不清、題意不明確、沒附檔案格式、沒有討論問題的態度~~~~~~以上愛莫能助。

TOP

        靜思自在 : 一句溫暖的話，就像往別人身上灑香水，自己會沾到兩三滴。
返回列表 上一主題