请教高手，一个排列组合问题！

Question

用VB找出0到N位数之间的所有组合（从1位数的组合一直到N位数的组合），而且每个组合里的数字不能有任何重复（像1233，9834555都不行）。在吧找出来的所有组合按从小到大顺序放到一个一维数组里面去。谢谢！

Answer 1

因为数字不能重复,最多10位数,
1位10个
2位 
3位
.......
10位
排列....
求排列数....天文数字
累死编代码的人
累死电脑.....公式在此:哪位代劳 p(n,m)=n(n-1)(n-2)……(n-m+1)= n!/(n-m)!(规定0!=1).
注意,这只是排列数,和排列出来完全是两回事

Answer 2

 
'参数1:     ChrArr存放参与组合的字符
 '参数2:     组成数的最大位数
 '参数3:     是否允许数种是否有重复数字 Private Function NumCombine(ChrArr() As String, DigitCnt As Long, SameFlg As Boolean) As Long()
          'DtCnt = 数字的个数 * 数的位数之方
          Dim A0 As Long, A1 As Long, A2 As Long, A3 As Long, A4 As Long, A5 As Long, A6 As Long, A7 As Long, A8 As Long, A9 As Long
          Dim Count As Long, RtnChrArr() As Long, Idx(0 To 9) As Long
          Dim MaxChrCntIndex As Long, WriteToArr As Boolean
          
          MaxChrCntIndex = UBound(ChrArr)
          For i = 0 To 9
              If i < DigitCnt Then
                 Idx(i) = MaxChrCntIndex
              Else
                 Idx(i) = 0
              End If
          Next          '循环层次决定数位的数量,ChrCnt决定参与组合的字符个数
          For A0 = 0 To Idx(0)        '个位
              For A1 = 0 To Idx(1)        '十位
                  For A2 = 0 To Idx(2)        '百位
                      For A3 = 0 To Idx(3)        '千位
                          For A4 = 0 To Idx(4)        '万位
                              For A5 = 0 To Idx(5)        '十万位
                                  For A6 = 0 To Idx(6)        '百万位
                                      For A7 = 0 To Idx(7)        '千万位
                                          For A8 = 0 To Idx(8)        '亿位
                                              For A9 = 0 To Idx(9)        '十亿位
                                                  WriteToArr = True
                                                  If SameFlg = False Then                      '假如不允许有相同的字符
                                                     If A0 = A1 And A1 = A2 Then             '
                                                        WriteToArr = False
                                                     End If
                                                  End If
                                                  If WriteToArr = True Then
                                                     ReDim Preserve RtnChrArr(Count) As Long
                                                     Select Case DigitCnt - 1
                                                            Case 0
                                                                 RtnChrArr(Count) = A0
                                                            Case 1
                                                                 RtnChrArr(Count) = A1 * 10 + A0
                                                            Case 2
                                                                 RtnChrArr(Count) = A2 * 100 + A1 * 10 + A0
                                                            Case 3
                                                                 RtnChrArr(Count) = A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                                            Case 4
                                                                 RtnChrArr(Count) = A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                                            Case 5
                                                                 RtnChrArr(Count) = A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                                            Case 6
                                                                 RtnChrArr(Count) = A6 * 1000000 + A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                                            Case 7
                                                                 RtnChrArr(Count) = A7 * 10000000 + A6 * 1000000 + A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                                            Case 8
                                                                 RtnChrArr(Count) = A8 * 100000000 + A7 * 10000000 + A6 * 1000000 + A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                                            Case 9
                                                                 RtnChrArr(Count) = A9 * 1000000000 + A8 * 100000000 + A7 * 10000000 + A6 * 1000000 + A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                                     End Select
                                                     If RtnChrArr(Count) = 0 Then
                                                     Stop
                                                     End If
                                                     Count = Count + 1
                                                 End If
                                             Next
                                         Next
                                      Next
                                  Next
                              Next
                          Next
                      Next
                  Next
              Next
          Next
     
          ReDim Preserve RtnChrArr(Count) As Long
          RtnChrArr(Count) = 0
          NumCombine = RtnChrArr
 End Function
 
 Private Function SortAsDX(OriArray() As Long, ElementCnt As Long, SortStyle As Long) As Long
          Dim CurrIdx As Long, AfterIdx As Long
          Dim SwapTimeCnt As Long          For CurrIdx = 0 To ElementCnt - 2
              For AfterIdx = CurrIdx + 1 To ElementCnt - 1
                  If SortStyle = 0 Then
                    If OriArray(CurrIdx) > OriArray(AfterIdx) Then
                       tmp = OriArray(CurrIdx)
                       OriArray(CurrIdx) = OriArray(AfterIdx)
                       OriArray(AfterIdx) = tmp
                       'SwapTimeCnt = SwapTimeCnt + 1
                    End If
                  Else
                    If OriArray(CurrIdx) < OriArray(AfterIdx) Then
                       tmp = OriArray(CurrIdx)
                       OriArray(CurrIdx) = OriArray(AfterIdx)
                       OriArray(AfterIdx) = tmp
                    End If
                  End If
              Next
          Next          SortAsDX = SwapTimeCnt
 End Function
        
 Private Function StrArrToFile(StrArr() As Long, FileName As String) As Long
         Dim Fp As Long, ArrMaxIndex As Long
         ArrMaxIndex = UBound(StrArr)
         Fp = FreeFile()
         Open FileName For Output As #Fp
              For i = 0 To ArrMaxIndex
                  Print #Fp, StrArr(i)
              Next
         Close #Fp
         StrArrToFile = ArrMaxIndex + 1
 End Function
 
 Private Sub form_Load()
         Dim ChrArr(0 To 9) As String
         Dim RltArr() As Long
         
         Me.AutoRedraw = True
        ChrArr(0) = "1"
        ChrArr(1) = "2"
        ChrArr(2) = "3"
        ChrArr(3) = "4"
        ChrArr(4) = "5"
        ChrArr(5) = "6"
        ChrArr(6) = "7"
        ChrArr(7) = "8"
        ChrArr(8) = "9"
        ChrArr(9) = "0"
        RltArr() = NumCombine(ChrArr(), 3, False)       '最大数的位数是3位，数中不允许有重复数字
          SortAsDX RltArr(), UBound(RltArr()) + 1, 0      '从小到大排序数组
        Me.Caption = StrArrToFile(RltArr, "d:\a.txt")   '数组写到文件
 End Sub
 

Answer 3

'参数1:    ChrArr存放参与组合的字符 
'参数2:    组成数的最大位数 
'参数3:    是否允许数种是否有重复数字 Private Function NumCombine(ChrArr() As String, DigitCnt As Long, SameFlg As Boolean) As Long() 
          'DtCnt = 数字的个数 * 数的位数之方 
          Dim A0 As Long, A1 As Long, A2 As Long, A3 As Long, A4 As Long, A5 As Long, A6 As Long, A7 As Long, A8 As Long, A9 As Long 
          Dim Count As Long, RtnChrArr() As Long, Idx(0 To 9) As Long 
          Dim MaxChrCntIndex As Long, WriteToArr As Boolean 
          
          MaxChrCntIndex = UBound(ChrArr) 
          For i = 0 To 9 
              If i < DigitCnt Then 
                Idx(i) = MaxChrCntIndex 
              Else 
                Idx(i) = 0 
              End If 
          Next           '循环层次决定数位的数量,ChrCnt决定参与组合的字符个数 
          For A0 = 0 To Idx(0)        '个位 
              For A1 = 0 To Idx(1)        '十位 
                  For A2 = 0 To Idx(2)        '百位 
                      For A3 = 0 To Idx(3)        '千位 
                          For A4 = 0 To Idx(4)        '万位 
                              For A5 = 0 To Idx(5)        '十万位 
                                  For A6 = 0 To Idx(6)        '百万位 
                                      For A7 = 0 To Idx(7)        '千万位 
                                          For A8 = 0 To Idx(8)        '亿位 
                                              For A9 = 0 To Idx(9)        '十亿位 
                                                  WriteToArr = True 
                                                  If SameFlg = False Then                      '假如不允许有相同的字符 
                                                    If A0 = A1 And A1 = A2 and A2 = A3 and A3 = A4 and A4 = A5 and A5 = A6 and A6 = A7 and A7 = A8 and A8 = A9  Then            ' 
                                                        WriteToArr = False 
                                                    End If 
                                                  End If 
                                                  If WriteToArr = True Then 
                                                    ReDim Preserve RtnChrArr(Count) As Long 
                                                    Select Case DigitCnt - 1 
                                                            Case 0 
                                                                RtnChrArr(Count) = A0 
                                                            Case 1 
                                                                RtnChrArr(Count) = A1 * 10 + A0 
                                                            Case 2 
                                                                RtnChrArr(Count) = A2 * 100 + A1 * 10 + A0 
                                                            Case 3 
                                                                RtnChrArr(Count) = A3 * 1000 + A2 * 100 + A1 * 10 + A0 
                                                            Case 4 
                                                                RtnChrArr(Count) = A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0 
                                                            Case 5 
                                                                RtnChrArr(Count) = A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0 
                                                            Case 6 
                                                                RtnChrArr(Count) = A6 * 1000000 + A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0 
                                                            Case 7 
                                                                RtnChrArr(Count) = A7 * 10000000 + A6 * 1000000 + A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0 
                                                            Case 8 
                                                                RtnChrArr(Count) = A8 * 100000000 + A7 * 10000000 + A6 * 1000000 + A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0 
                                                            Case 9 
                                                                RtnChrArr(Count) = A9 * 1000000000 + A8 * 100000000 + A7 * 10000000 + A6 * 1000000 + A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0 
                                                    End Select 
                                                    If RtnChrArr(Count) = 0 Then 
                                                    Stop 
                                                    End If 
                                                    Count = Count + 1 
                                                End If 
                                            Next 
                                        Next 
                                      Next 
                                  Next 
                              Next 
                          Next 
                      Next 
                  Next 
              Next 
          Next 
    
          ReDim Preserve RtnChrArr(Count) As Long 
          RtnChrArr(Count) = 0 
          NumCombine = RtnChrArr 
End Function Private Function SortAsDX(OriArray() As Long, ElementCnt As Long, SortStyle As Long) As Long 
          Dim CurrIdx As Long, AfterIdx As Long 
          Dim SwapTimeCnt As Long           For CurrIdx = 0 To ElementCnt - 2 
              For AfterIdx = CurrIdx + 1 To ElementCnt - 1 
                  If SortStyle = 0 Then 
                    If OriArray(CurrIdx) > OriArray(AfterIdx) Then 
                      tmp = OriArray(CurrIdx) 
                      OriArray(CurrIdx) = OriArray(AfterIdx) 
                      OriArray(AfterIdx) = tmp 
                      'SwapTimeCnt = SwapTimeCnt + 1 
                    End If 
                  Else 
                    If OriArray(CurrIdx) < OriArray(AfterIdx) Then 
                      tmp = OriArray(CurrIdx) 
                      OriArray(CurrIdx) = OriArray(AfterIdx) 
                      OriArray(AfterIdx) = tmp 
                    End If 
                  End If 
              Next 
          Next           SortAsDX = SwapTimeCnt 
End Function 
        
Private Function StrArrToFile(StrArr() As Long, FileName As String) As Long 
        Dim Fp As Long, ArrMaxIndex As Long 
        ArrMaxIndex = UBound(StrArr) 
        Fp = FreeFile() 
        Open FileName For Output As #Fp 
              For i = 0 To ArrMaxIndex 
                  Print #Fp, StrArr(i) 
              Next 
        Close #Fp 
        StrArrToFile = ArrMaxIndex + 1 
End Function Private Sub form_Load() 
        Dim ChrArr(0 To 9) As String 
        Dim RltArr() As Long 
        
        Me.AutoRedraw = True 
        ChrArr(0) = "1" 
        ChrArr(1) = "2" 
        ChrArr(2) = "3" 
        ChrArr(3) = "4" 
        ChrArr(4) = "5" 
        ChrArr(5) = "6" 
        ChrArr(6) = "7" 
        ChrArr(7) = "8" 
        ChrArr(8) = "9" 
        ChrArr(9) = "0" 
        RltArr() = NumCombine(ChrArr(), 10, False)      '此处最大数的位数是10位，数中不允许有重复数字 
          SortAsDX RltArr(), UBound(RltArr()) + 1, 0      '从小到大排序数组 
        Me.Caption = StrArrToFile(RltArr, "d:\a.txt")  '数组写到文件 
End Sub 

Answer 4

Private Sub Command1_Click()
Dim i As Long, j As Long
Dim Time1 As Date, Time2 As Date
    j = 0
    Time1 = Now
    For i = 0 To 99999
        If CheckNum(i) = True Then
            j = j + 1
        End If
        DoEvents
    Next i
    Time2 = Now
    MsgBox j '个数
    MsgBox DateDiff("s", Time1, Time2) '时间差
End Sub
Private Function CheckNum(ByVal Num As Long) As Boolean
Dim strNum As String, strSNum As String, strLNum As String
Dim i As Integer, strLen As Integer
    strNum = Trim(str(Num))
    strLen = Len(strNum)
    For i = 1 To strLen
        strSNum = Mid(strNum, i, 1)
        strLNum = Replace(strNum, strSNum, "")
        If strLen - Len(strLNum) > 1 Then
            Exit For
        End If
    Next i
    If i - 1 = strLen Then
        CheckNum = True
    Else
        CheckNum = False
    End If
End Function另外一种思路，不过结果好像跟我预期的不太一样，不知道哪里的问题，明天再研究吧

Answer 5

'引用Microsoft VBScript Regular Expression 5.5
Private Sub Command1_Click()
test (3) 'test(n),n就是位数
End Sub
Sub test(ByVal n As Integer)
Dim objRegExp As RegExp
Set objRegExp = New RegExp
objRegExp.Pattern = "(\d)(?:.*)\1"
objRegExp.IgnoreCase = True
objRegExp.Global = True
For i = 0 To Val(Left("9876543210", n))
   If (objRegExp.test(i) = False) Then Debug.Print i '这里只打印输出，要存到数组里去自己搞
Next
End Sub

Answer 6

如果位数多了，上面Sub test(ByVal n As Integer) 最好改为Sub test(ByVal n As long)，不过位数多了电脑也受不了了 

Answer 7

Private Function NumCombine2(ChrArr() As String, DigitCnt As Long, SameFlg As Boolean) As Long()
         'DtCnt = 数字的个数 * 数的位数之方
         Dim A0 As Long, A1 As Long, A2 As Long, A3 As Long, A4 As Long, A5 As Long, A6 As Long, A7 As Long, A8 As Long, A9 As Long
         Dim Count As Long, RtnChrArr() As Long, ChrCntMaxIndex(0 To 9) As Long
         Dim MaxChrCntIndex As Long, WriteToArr As Boolean, TmpLng As Long
         
         MaxChrCntIndex = UBound(ChrArr)
         For i = 0 To 9
             If i < DigitCnt Then
                ChrCntMaxIndex(i) = MaxChrCntIndex
             Else
                ChrCntMaxIndex(i) = 0
             End If
         Next         '循环层次决定数位的数量,ChrCnt决定参与组合的字符个数
         For A0 = 0 To ChrCntMaxIndex(0)        '个位
             For A1 = 0 To ChrCntMaxIndex(1)        '十位
                 For A2 = 0 To ChrCntMaxIndex(2)        '百位
                     For A3 = 0 To ChrCntMaxIndex(3)        '千位
                         For A4 = 0 To ChrCntMaxIndex(4)        '万位
                             For A5 = 0 To ChrCntMaxIndex(5)        '十万位
                                 For A6 = 0 To ChrCntMaxIndex(6)        '百万位
                                     For A7 = 0 To ChrCntMaxIndex(7)        '千万位
                                         For A8 = 0 To ChrCntMaxIndex(8)        '亿位
                                             For A9 = 0 To ChrCntMaxIndex(9)        '十亿位
                                                Select Case DigitCnt - 1
                                                       Case 0
                                                            TmpLng = A0
                                                       Case 1
                                                            TmpLng = A1 * 10 + A0
                                                       Case 2
                                                            TmpLng = A2 * 100 + A1 * 10 + A0
                                                       Case 3
                                                            TmpLng = A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                                       Case 4
                                                            TmpLng = A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                                       Case 5
                                                            TmpLng = A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                                       Case 6
                                                            TmpLng = A6 * 1000000 + A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                                       Case 7
                                                            TmpLng = A7 * 10000000 + A6 * 1000000 + A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                                       Case 8
                                                            TmpLng = A8 * 100000000 + A7 * 10000000 + A6 * 1000000 + A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                                       Case 9
                                                            TmpLng = A9 * 1000000000 + A8 * 100000000 + A7 * 10000000 + A6 * 1000000 + A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                                End Select
                                                
                                                WriteToArr = True
                                                If SameFlg = False Then                      '假如不允许有相同的字符
                                                   isCF = JudgeCF(TmpLng)
                                                   If isCF = True Then
                                                      WriteToArr = False
                                                   End If
                                                End If                                                If WriteToArr = True Then
                                                   ReDim Preserve RtnChrArr(0 To Count) As Long
                                                   RtnChrArr(Count) = TmpLng
                                                   Count = Count + 1
                                                End If
                                                    
                                            Next
                                        Next
                                     Next
                                 Next
                             Next
                         Next
                     Next
                 Next
             Next
         Next         NumCombine2 = RtnChrArr
End FunctionPrivate Function JudgeCF(MyLng As Long) As Boolean
        Dim MyStr As String, i As Long, j As Long, MyLen1 As Long, MyLen2 As Long, CurrChr As String
        MyStr = MyLng
        MyLen2 = Len(MyStr)
        MyLen1 = MyLen2 - 1
        For i = 1 To MyLen1
            CurrChr = Mid(MyStr, i, 1)
            For j = i + 1 To MyLen2
                If CurrChr = Mid(MyStr, j, 1) Then
                   JudgeCF = True
                End If
            Next
        NextEnd FunctionPrivate Function SortAsDX(OriArray() As Long, ElementCnt As Long, SortStyle As Long) As Long
         Dim CurrIdx As Long, AfterIdx As Long
         Dim SwapTimeCnt As Long         For CurrIdx = 0 To ElementCnt - 2
             For AfterIdx = CurrIdx + 1 To ElementCnt - 1
                 If SortStyle = 0 Then
                   If OriArray(CurrIdx) > OriArray(AfterIdx) Then
                      tmp = OriArray(CurrIdx)
                      OriArray(CurrIdx) = OriArray(AfterIdx)
                      OriArray(AfterIdx) = tmp
                      'SwapTimeCnt = SwapTimeCnt + 1
                   End If
                 Else
                   If OriArray(CurrIdx) < OriArray(AfterIdx) Then
                      tmp = OriArray(CurrIdx)
                      OriArray(CurrIdx) = OriArray(AfterIdx)
                      OriArray(AfterIdx) = tmp
                   End If
                 End If
             Next
         Next         SortAsDX = SwapTimeCnt
End Function
       
Private Function StrArrToFile(StrArr() As Long, FileName As String) As Long
        Dim Fp As Long, ArrMaxIndex As Long
        ArrMaxIndex = UBound(StrArr)
        Fp = FreeFile()
        Open FileName For Output As #Fp
             For i = 0 To ArrMaxIndex
                 Print #Fp, StrArr(i)
             Next
        Close #Fp
        StrArrToFile = ArrMaxIndex + 1
End FunctionPrivate Sub form_Load()
        Dim ChrArr(0 To 9) As String
        Dim RltArr() As Long       ChrArr(0) = "1"
       ChrArr(1) = "2"
       ChrArr(2) = "3"
       ChrArr(3) = "4"
       ChrArr(4) = "5"
       ChrArr(5) = "6"
       ChrArr(6) = "7"
       ChrArr(7) = "8"
       ChrArr(8) = "9"
       ChrArr(9) = "0"
       RltArr() = NumCombine2(ChrArr(), 3, False)       '最大数的位数是3位，数中不允许有重复数字
       SortAsDX RltArr(), UBound(RltArr()) + 1, 0      '从小到大排序数组
       Me.Caption = StrArrToFile(RltArr, "d:\a.txt")   '数组写到文件End Sub

Answer 8

纯粹的自己的代码12楼的这个版本纠正了前面所有的错误，拷贝即可使用不需要任何修改稍作修改也可做非数字组合 如ABC字母组合等

Answer 9

谢谢tgstgstgs，tongnaifu和lsftest这几位朋友，特别是tgstgstgs速度真牛，幸苦了。
我先看看明天再请教。

Answer 10

tgstgstgs, 我试了你的代码，蛮好用的，只是我只需要的这1到9位数的组合（每个组合里的数字不分顺序，像123，231和321对我的程序来说都是一样的，只是最后把所有的组合安大小排序），请问该怎么把针对每个位数的排序消除掉（就像如果是9位数组合我只需要123456789或者154239876而不需要把里面数字排序）？谢谢

Answer 11

'我这个是专用于彩票 M 选 N 的Option ExplicitPrivate Sub Command1_Click()
  Dim Arr() As String
  
  Arr = GetData(2)  '取得二位不重复的数据
  
  Dim i As Long
  For i = 1 To UBound(Arr)
    Print Arr(i)   '编历取得的数据
    
  Next
End Sub'************************取得N位不重复的数据。
Private Function GetData(ByVal N As Long) As String()
   Dim i As Long
   Dim j As Long
   Dim sAns() As String
   Dim Count As Long
   Dim fStr As String
   fStr = String(N, Asc("0"))
   
   Dim Data() As Long
   ReDim Data(N) As Long
   
   Dim strData As String
   
   Data(0) = -1
   
   Dim IsTrue As Boolean
   For i = 0 To 10 ^ N
      strData = Format(i, fStr)
      For j = 1 To N
         Data(j) = Mid(strData, j, 1)
         IsTrue = True
         If Data(j) <= Data(j - 1) Then
            IsTrue = False
            Exit For
         End If
      Next
      
      If IsTrue Then
         Count = Count + 1
         ReDim Preserve sAns(Count) As String
         sAns(Count) = strData
      End If
   Next
   
   GetData = sAns
End Function

Answer 12

'引用Microsoft VBScript Regular Expression 5.5
Dim a(0 To 1022) As String '结果在这个数组里
Dim b(0 To 1022) As String
Dim recount As Long
Private Sub Command1_Click()
Erase a
Erase b
recount = 0
For l = 1 To 3 '列出1～3位时的结果
test (l) 'test(l),l就是位数
Next
For k = 0 To recount - 1
Debug.Print a(k), "总数：" & Str(recount) & "个"
Next
End Sub
Sub test(ByVal n As Integer)result = 1c = Array(2, 3, 5, 7, 11, 13, 17, 19, 23, 29)
Dim objRegExp As RegExp
Set objRegExp = New RegExp
objRegExp.Pattern = "(\d)(?:.*)\1"
objRegExp.IgnoreCase = True
objRegExp.Global = True
For i = Val(Left("0123456789", n)) To Val(Left("9876543210", n))
    teststr = String(n, "0")
    teststr = Format(i, teststr)
        If (objRegExp.test(teststr) = False) Then
            For j = 1 To Len(teststr)
                result = result * c(Val(Mid(teststr, j, 1)))
            Next
            resultstr = Join(b, ",")
            If InStr(resultstr, result) = 0 Then
                a(recount) = teststr
                b(recount) = result
                recount = recount + 1
            End If
        End If
        result = 1
NextEnd Sub

Answer 13

' Val(Left("0123456789", n)) To Val(Left("9876543210", n)) 改为：
' Val(Left("0123456789", n)) To Val(Right("0123456789", n)),减少循环.
'引用Microsoft VBScript Regular Expression 5.5
Dim a(0 To 1022) As String '结果在这个数组里
Dim b(0 To 1022) As String
Dim recount As LongPrivate Sub Command1_Click()
Erase a
Erase b
recount = 0
For l = 3 To 3 '列出1～3位时的结果
test (l) 'test(l),l就是位数
Next
For k = 0 To recount - 1
Debug.Print a(k), "总数：" & Str(recount) & "个"
NextEnd Sub
Sub test(ByVal n As Integer)result = 1c = Array(2, 3, 5, 7, 11, 13, 17, 19, 23, 29)
Dim objRegExp As RegExp
Set objRegExp = New RegExp
objRegExp.Pattern = "(\d)(?:.*)\1"
objRegExp.IgnoreCase = True
objRegExp.Global = True
For i = Val(Left("0123456789", n)) To Val(Right("0123456789", n))
    teststr = String(n, "0")
    teststr = Format(i, teststr)
        If (objRegExp.test(teststr) = False) Then
            For j = 1 To Len(teststr)
                result = result * c(Val(Mid(teststr, j, 1)))
            Next
            resultstr = Join(b, ",")
            If InStr(resultstr, result) = 0 Then
                a(recount) = teststr
                b(recount) = result
                recount = recount + 1
            End If
        End If
        result = 1
NextEnd Sub

Answer 14

修改了一个错误：'引用Microsoft VBScript Regular Expression 5.5
Dim a(0 To 1022) As String '结果在这个数组里
Dim b(0 To 1022) As String
Dim recount As LongPrivate Sub Command1_Click()
Erase a
Erase b
recount = 0
For l = 1 To 4 '列出1～3位时的结果
test (l) 'test(l),l就是位数
Next
For k = 0 To recount - 1
Debug.Print a(k), "总数：" & Str(recount) & "个"
NextEnd Sub
Sub test(ByVal n As Integer)result = 1c = Array(2, 3, 5, 7, 11, 13, 17, 19, 23, 29)
Dim objRegExp As RegExp
Set objRegExp = New RegExp
objRegExp.Pattern = "(\d)(?:.*)\1"
objRegExp.IgnoreCase = True
objRegExp.Global = True
For i = Val(Left("0123456789", n)) To Val(Right("0123456789", n))
    teststr = String(n, "0")
    teststr = Format(i, teststr)
        If (objRegExp.test(teststr) = False) Then
            For j = 1 To Len(teststr)
                result = result * c(Val(Mid(teststr, j, 1)))
            Next
            resultstr = "," + Join(b, ",")
            If InStr(resultstr, "," & CStr(result) & ",") = 0 Then
                a(recount) = teststr
                b(recount) = result
                recount = recount + 1
            End If
        End If
        result = 1
NextEnd Sub

Answer 15

历遍始终太慢，位数少还能玩玩，去到7、8位就有点麻烦了还是用回通用方法吧，参看：
http://club.excelhome.net/dispbbs.asp?BoardID=2&ID=356105&replyID=&skin=0

Answer 16

既然相同组合的不同排列只计一次，那么统一规定从左至右的位按数字从大到小排列。
由于 9876543210 超过了 Long 的最大值，数据类型用 Variant/Deciaml 存储。
Option Explicit
#Const OUTPUT_VALUES = True#If OUTPUT_VALUES Then
    Private m_aValues(1023 - 1) As Variant '先在 OUTPUT_VALUES = False 下求得 1023
    Private m_lCount As Long
    
    Sub AddValue(ByVal v As Variant)
        m_aValues(m_lCount) = v
        m_lCount = m_lCount + 1
    End Sub
    
    Sub PrintValues()
        Dim i As Long
        Debug.Print "Values(" & m_lCount & ") = {"
        For i = 0 To m_lCount - 1
            If ((i Mod 10) = 0) And (i <> 0) Then Debug.Print
            Debug.Print Format$(m_aValues(i), "@@@@@@@@@@") & ", ";
        Next
        Debug.Print "}"
    End Sub
#End IfSub Main()
    Dim l As Long, lSum As Long
    Dim i As Long
    
    For i = 1 To 10
        l = f(CDec(0), 9, i)
        lSum = lSum + l
        Debug.Print i, l
    Next
    Debug.Print , lSum
    
#If OUTPUT_VALUES Then
    PrintValues
#End If
End Sub'求用数字 [0-MaxDigtis] 组成的 Count 位数,Prefix 为前面已组合的数
Function f(ByVal Prefix As Variant, ByVal MaxDigits As Long, ByVal Count As Long) As Long
    Dim MinDigits As Long
    Dim i As Long
    
    If (MaxDigits + 1) < Count Then Exit Function
    
    '0 不能作为最高位
    If (Prefix = 0) And (Count > 1) Then
        MinDigits = 1
    Else
        MinDigits = 0
    End If
    
    
    If Count = 1 Then
#If OUTPUT_VALUES Then
        For i = MinDigits To MaxDigits
            AddValue (Prefix * 10 + i)
        Next
#End If
        f = f + (MaxDigits - MinDigits + 1)
    Else
        For i = MinDigits To MaxDigits
            f = f + f(Prefix * 10 + i, i - 1, Count - 1)
        Next
    End If
End Function

Answer 17

输出
－－－－－－－－
 1             10 
 2             45 
 3             120 
 4             210 
 5             252 
 6             210 
 7             120 
 8             45 
 9             10 
 10            1 
               1023 
Values(1023) = {
         0,          1,          2,          3,          4,          5,          6,          7,          8,          9, 
        10,         20,         21,         30,         31,         32,         40,         41,         42,         43, 
        50,         51,         52,         53,         54,         60,         61,         62,         63,         64, 
        65,         70,         71,         72,         73,         74,         75,         76,         80,         81, 
        82,         83,         84,         85,         86,         87,         90,         91,         92,         93, 
        94,         95,         96,         97,         98,        210,        310,        320,        321,        410, 
       420,        421,        430,        431,        432,        510,        520,        521,        530,        531, 
       532,        540,        541,        542,        543,        610,        620,        621,        630,        631, 
       632,        640,        641,        642,        643,        650,        651,        652,        653,        654, 
       710,        720,        721,        730,        731,        732,        740,        741,        742,        743, 
       750,        751,        752,        753,        754,        760,        761,        762,        763,        764, 
       765,        810,        820,        821,        830,        831,        832,        840,        841,        842, 
       843,        850,        851,        852,        853,        854,        860,        861,        862,        863, 
       864,        865,        870,        871,        872,        873,        874,        875,        876,        910, 
       920,        921,        930,        931,        932,        940,        941,        942,        943,        950, 
       951,        952,        953,        954,        960,        961,        962,        963,        964,        965, 
       970,        971,        972,        973,        974,        975,        976,        980,        981,        982, 
       983,        984,        985,        986,        987,       3210,       4210,       4310,       4320,       4321, 
      5210,       5310,       5320,       5321,       5410,       5420,       5421,       5430,       5431,       5432, 
      6210,       6310,       6320,       6321,       6410,       6420,       6421,       6430,       6431,       6432, 
      6510,       6520,       6521,       6530,       6531,       6532,       6540,       6541,       6542,       6543, 
      7210,       7310,       7320,       7321,       7410,       7420,       7421,       7430,       7431,       7432, 
      7510,       7520,       7521,       7530,       7531,       7532,       7540,       7541,       7542,       7543, 
      7610,       7620,       7621,       7630,       7631,       7632,       7640,       7641,       7642,       7643, 
      7650,       7651,       7652,       7653,       7654,       8210,       8310,       8320,       8321,       8410, 
      8420,       8421,       8430,       8431,       8432,       8510,       8520,       8521,       8530,       8531, 
      8532,       8540,       8541,       8542,       8543,       8610,       8620,       8621,       8630,       8631, 
      8632,       8640,       8641,       8642,       8643,       8650,       8651,       8652,       8653,       8654, 
      8710,       8720,       8721,       8730,       8731,       8732,       8740,       8741,       8742,       8743, 
      8750,       8751,       8752,       8753,       8754,       8760,       8761,       8762,       8763,       8764, 
      8765,       9210,       9310,       9320,       9321,       9410,       9420,       9421,       9430,       9431, 
      9432,       9510,       9520,       9521,       9530,       9531,       9532,       9540,       9541,       9542, 
      9543,       9610,       9620,       9621,       9630,       9631,       9632,       9640,       9641,       9642, 
      9643,       9650,       9651,       9652,       9653,       9654,       9710,       9720,       9721,       9730, 
      9731,       9732,       9740,       9741,       9742,       9743,       9750,       9751,       9752,       9753, 
      9754,       9760,       9761,       9762,       9763,       9764,       9765,       9810,       9820,       9821, 
      9830,       9831,       9832,       9840,       9841,       9842,       9843,       9850,       9851,       9852, 
      9853,       9854,       9860,       9861,       9862,       9863,       9864,       9865,       9870,       9871, 
      9872,       9873,       9874,       9875,       9876,      43210,      53210,      54210,      54310,      54320,

Answer 18

'为了不破坏程序的完整性，是代码拷贝就能使用，还是重复贴出了部分原有的代码，看起来有点罗嗦'新增了   使所有长度相同的数不含相同的字符   的功能Private Function NumCombine2(ChrArr() As String, DigitCnt As Long, SameFlg As Boolean) As Long()
'DtCnt = 数字的个数 * 数的位数之方
Dim A0 As Long, A1 As Long, A2 As Long, A3 As Long, A4 As Long, A5 As Long, A6 As Long, A7 As Long, A8 As Long, A9 As Long
Dim Count As Long, RtnChrArr() As Long, ChrCntMaxIndex(0 To 9) As Long
Dim MaxChrCntIndex As Long, WriteToArr As Boolean, TmpLng As LongMaxChrCntIndex = UBound(ChrArr)
For i = 0 To 9
    If i < DigitCnt Then
        ChrCntMaxIndex(i) = MaxChrCntIndex
    Else
        ChrCntMaxIndex(i) = 0
    End If
Next'循环层次决定数位的数量,ChrCnt决定参与组合的字符个数
For A0 = 0 To ChrCntMaxIndex(0)        '个位
    For A1 = 0 To ChrCntMaxIndex(1)        '十位
        For A2 = 0 To ChrCntMaxIndex(2)        '百位
            For A3 = 0 To ChrCntMaxIndex(3)        '千位
                For A4 = 0 To ChrCntMaxIndex(4)        '万位
                    For A5 = 0 To ChrCntMaxIndex(5)        '十万位
                        For A6 = 0 To ChrCntMaxIndex(6)        '百万位
                            For A7 = 0 To ChrCntMaxIndex(7)        '千万位
                                For A8 = 0 To ChrCntMaxIndex(8)        '亿位
                                    For A9 = 0 To ChrCntMaxIndex(9)        '十亿位
                                        Select Case DigitCnt - 1
                                              Case 0
                                                    TmpLng = A0
                                              Case 1
                                                    TmpLng = A1 * 10 + A0
                                              Case 2
                                                    TmpLng = A2 * 100 + A1 * 10 + A0
                                              Case 3
                                                    TmpLng = A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                              Case 4
                                                    TmpLng = A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                              Case 5
                                                    TmpLng = A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                              Case 6
                                                    TmpLng = A6 * 1000000 + A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                              Case 7
                                                    TmpLng = A7 * 10000000 + A6 * 1000000 + A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                              Case 8
                                                    TmpLng = A8 * 100000000 + A7 * 10000000 + A6 * 1000000 + A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                              Case 9
                                                    TmpLng = A9 * 1000000000 + A8 * 100000000 + A7 * 10000000 + A6 * 1000000 + A5 * 100000 + A4 * 10000 + A3 * 1000 + A2 * 100 + A1 * 10 + A0
                                        End Select
                                        
                                        WriteToArr = True
                                        If SameFlg = False Then                      '假如不允许有相同的字符
                                          isCF = JudgeCF(TmpLng)
                                          If isCF = True Then
                                              WriteToArr = False
                                          End If
                                        End If                                        If WriteToArr = True Then
                                          ReDim Preserve RtnChrArr(0 To Count) As Long
                                          RtnChrArr(Count) = TmpLng
                                          Count = Count + 1
                                        End If
                                            
                                    Next
                                Next
                            Next
                        Next
                    Next
                Next
            Next
        Next
    Next
NextNumCombine2 = RtnChrArr
End FunctionPrivate Function JudgeCF(MyLng As Long) As Boolean
Dim MyStr As String, i As Long, j As Long, MyLen1 As Long, MyLen2 As Long, CurrChr As String
MyStr = MyLng
MyLen2 = Len(MyStr)
MyLen1 = MyLen2 - 1
For i = 1 To MyLen1
    CurrChr = Mid(MyStr, i, 1)
    For j = i + 1 To MyLen2
        If CurrChr = Mid(MyStr, j, 1) Then
          JudgeCF = True
        End If
    Next
NextEnd FunctionPrivate Function SortAsDX(OriArray() As Long, ElementCnt As Long, SortStyle As Long) As Long
Dim CurrIdx As Long, AfterIdx As Long
Dim SwapTimeCnt As LongFor CurrIdx = 0 To ElementCnt - 2
    For AfterIdx = CurrIdx + 1 To ElementCnt - 1
        If SortStyle = 0 Then
          If OriArray(CurrIdx) > OriArray(AfterIdx) Then
              tmp = OriArray(CurrIdx)
              OriArray(CurrIdx) = OriArray(AfterIdx)
              OriArray(AfterIdx) = tmp
              'SwapTimeCnt = SwapTimeCnt + 1
          End If
        Else
          If OriArray(CurrIdx) < OriArray(AfterIdx) Then
              tmp = OriArray(CurrIdx)
              OriArray(CurrIdx) = OriArray(AfterIdx)
              OriArray(AfterIdx) = tmp
          End If
        End If
    Next
NextSortAsDX = SwapTimeCnt
End FunctionPrivate Sub SameLenForNoSameChar(RltArr() As Long)
        Dim RltArrMaxIndex As Long
        Dim MyStr As String, i As Long, m As Long, n As Long, MyLen1 As Long, MyLen2 As Long, CurrChr As String
        Dim ChrVal1 As Integer, ChrVal2 As Integer
        
        MyStr = MyLng
        
        
        RltArrMaxIndex = UBound(RltArr)
        
        For i = 0 To RltArrMaxIndex
            MyStr = RltArr(i)
            MyLen2 = Len(MyStr)
            MyLen1 = MyLen2 - 1
            For m = 1 To MyLen1
                ChrVal1 = Mid(MyStr, m, 1)
                For n = m + 1 To MyLen2
                    ChrVal2 = Mid(MyStr, n, 1)
                    If ChrVal2 < ChrVal1 Then
                       RltArr(i) = -1
                       GoTo MyLabel
                    End If
                Next
            Next
MyLabel:
        Next
End SubPrivate Sub form_Load()Dim ChrArr(0 To 9) As String
Dim RltArr() As Long
Dim RltArrMaxIndex As Long    '新增ChrArr(0) = "1"
ChrArr(1) = "2"
ChrArr(2) = "3"
ChrArr(3) = "4"
ChrArr(4) = "5"
ChrArr(5) = "6"
ChrArr(6) = "7"
ChrArr(7) = "8"
ChrArr(8) = "9"
ChrArr(9) = "0"
RltArr() = NumCombine2(ChrArr(), 3, False)      '最大数的位数是3位，数中不允许有重复数字
SortAsDX RltArr(), UBound(RltArr()) + 1, 0      '从小到大排序数组'如下全是新增代码
SameLenForNoSameChar RltArr                     '使所有长度相同的数不含相同的字符RltArrMaxIndex = UBound(RltArr)Open "D:\a.txt" For Output As #1
    For i = 0 To RltArrMaxIndex
        If RltArr(i) <> -1 Then
           Print #1, RltArr(i)
        End If
    Next
Close #1End Sub

Answer 19

相当于10个数 
C(10,0)+C(10,1)+C(10,2)+..C(10,10)=2^10=1024 
C(10,0) 相当于 1个数都不取 根据题意排除 所以总数是
1024-C(10,0)=1023再简单点 就是10个数  每个数2种情况 存在 or 不存在 进行全排列 2^10-1

Answer 20

上面的代码太复杂了，其实排列是一种很简单的算法，下面我写了一个可以对任意字符串进行任意排列的函数，供LZ参考：
Option ExplicitSub main()
    RansackDictionary "0123456789", 3, True
End Sub'* ************************************************************ *
'            函数名称：通用排列算法
'            参数说明：sDictionary : 需要进行排列的字典
'                      nDigit : 需要进行排列的位数
'                      bExclude : 是否排除相邻元素相同的情况
'            作者：lyserver
'* ************************************************************ *
Public Function RansackDictionary(ByVal sDictionary As String, ByVal nDigit As Integer, ByVal bExclude As Boolean)
    Dim sValue As String, lVal_1 As String, lVal_2 As String
    Dim i As Long, j As Long, k As Long, nBound As Long, nDictionaryLen As Long
    
    nDictionaryLen = Len(sDictionary)
    If nDigit < 1 Or nDigit > nDictionaryLen Then Exit Function
    nBound = nDictionaryLen ^ nDigit - 1    For i = 1 To nDigit
        For j = 0 To nDictionaryLen ^ i - 1
            lVal_2 = ""
            sValue = ""
            For k = i To 1 Step -1
                lVal_1 = Mid(sDictionary, Fix(j / (nDictionaryLen ^ (k - 1))) Mod nDictionaryLen + 1, 1)
                If (Not bExclude) Or lVal_1 <> lVal_2 Then  '排除相邻相同的情况
                    lVal_2 = lVal_1
                    sValue = sValue & lVal_1
                End If
            Next
            If Len(sValue) = i Then Debug.Print sValue
            DoEvents
        Next
    Next
End Function

Answer 21

补充说明：上面的代码不仅实现相邻相同元素的排斥功能，还实现了排序。不过由于对10个字符进行全排列时，数组非常大，有10^10+10^9+10^8+10^7+...10^1之多，占用内存太多了，故未放到一个数组里，LZ可把debug.print语句改为保存到文件中，以验证结果是否正确。
在写这个代码之前，我搜索了一些相关的代码，发现最好的也就是用了回调，但回调有一个致命的弱点，当字典太大（如LZ要求的10位或以上时），肯定会出现栈溢出，而导致程序崩溃。而我写的这个函数，应该目前效率最后、最精短的排列代码了。

Answer 22

研究了tgstgstgs ，fvflove，lsftest,Tiger_Zhao 几位朋友的方法，谢谢了。Tiger_Zhao 请问能帮下忙把你代码改成函数的形式么发上来一下么，这样就方便引用（不使用Mian（））以及适用于找任可0到N(N<9)之间所有组合，谢谢。

Answer 23

lyserver谢了， 我先试试你的代码

Answer 24

旅游三日,坐在车上头昏脑胀,为了保持清醒就强迫自己进行有必要和没必要的脑力活动,于是又想到了这个帖子,想到了另一种方法:
Private Sub Command1_Click()
Dim b(1 To 1024) As String '保存结果
Dim totalcount As Long
totalcount = 1
 start = 1
a = Array("0", "1", "2", "3", "4", "5", "6", "7", "8", "9")
For Bit = 1 To 10
For i = 0 To 2 ^ 10 - 1
tempresult = DEC_to_BIN(i)
If Len(tempresult) - Len(Replace(tempresult, "1", "")) = Bit Then
    
        Do While InStr(start, tempresult, "1") <> 0
            result = result + a(InStr(start, tempresult, "1") - 1)
            start = InStr(start, tempresult, "1") + 1
        Loop
    b(totalcount) = result
 Text1.Text = Text1.Text + result + "        " + CStr(totalcount) + vbCrLf
     totalcount = totalcount + 1
    result = ""
    start = 1
End If
Next
NextMsgBox "ok"
End Sub
Public Function DEC_to_BIN(ByVal Dec As Long) As String
    DEC_to_BIN = ""
    Do While Dec > 0
        DEC_to_BIN = Dec Mod 2 & DEC_to_BIN
        Dec = Dec \ 2
    Loop
    DEC_to_BIN = StrReverse(DEC_to_BIN)
End Function上面的代码列出10个数的1~10位全部组合在我机子里不超过6妙,如果结果只保存进b()数组而不必显示则基本不需要1妙,而且还是在没有优化的情况下的测试结果.
但这个结果由于算法的原因,是没有排序的,排序部分就免了吧.

Answer 25

假如不考虑 排序
循环100次 大概在0.5秒 
Function getnum(stri() As String * 10)
  Dim i As Long, j As Long, k As Long, strt As String
  Dim strl(9) As Long
  ReDim stri(1 To 1023)
  For i = 0 To 9
    strl(i) = 2 ^ i
  Next
  For i = 1 To 2 ^ 10 - 1
    strt = ""
    For j = 9 To 0 Step -1
      If strl(j) And i Then
        strt = strt & CStr(j)
      End If
    Next
    stri(i) = strt
  Next
End Function
Private Sub Command1_Click()
  Dim t1 As Date, t2 As Date
  Dim times As Long
  Dim stri() As String * 10
  t1 = Timer
  For times = 1 To 100
    Call getnum(stri)
  Next
  t2 = Timer
  Debug.Print Format(t2 - t1, "0.0000")
  
  For i = 1 To UBound(stri)
    List1.AddItem stri(i)
  Next
End Sub

Answer 26

如果要排除每一组排列中有任意字符相同的情况,在原代码上修改一句就可以了.
Option Explicit Sub main() 
    RansackDictionary "0123456789", 3
End Sub '* ************************************************************ * 
'            函数名称：通用排列算法 
'            参数说明：sDictionary : 需要进行排列的字典 
'                      nDigit : 需要进行排列的位数 
'                      bExclude : 是否排除相邻元素相同的情况 
'            作者：lyserver 
'* ************************************************************ * 
Public Function RansackDictionary(ByVal sDictionary As String, ByVal nDigit As Integer) 
    Dim sValue As String, lVal_1 As String, lVal_2 As String 
    Dim i As Long, j As Long, k As Long, nBound As Long, nDictionaryLen As Long 
    
    nDictionaryLen = Len(sDictionary) 
    If nDigit < 1 Or nDigit > nDictionaryLen Then Exit Function 
    nBound = nDictionaryLen ^ nDigit - 1     For i = 1 To nDigit 
        For j = 0 To nDictionaryLen ^ i - 1 
            lVal_2 = "" 
            sValue = "" 
            For k = i To 1 Step -1 
                lVal_1 = Mid(sDictionary, Fix(j / (nDictionaryLen ^ (k - 1))) Mod nDictionaryLen + 1, 1) 
                If Instr(lVal_1,lVal_2)=0 Then  '排除任何相同的字符
                    lVal_2 = lVal_1 
                    sValue = sValue & lVal_1 
                End If 
            Next 
            If Len(sValue) = i Then Debug.Print sValue 
            DoEvents 
        Next 
    Next 
End Function 

Answer 27

如何封装函数是你自己的事了，问题已经解决了。如果什么事都帮你完成就不是只拿CSDN中的分了，要签商业合同了。