[求助]請問各位大俠,有方法統計1-49數字組合數量?

aborr

太感謝了,完全正確,Northwolves大俠非常謝謝您,在8樓的連結,發現我提的問題被高手收集了,很好,更謝謝您這位高手花時間幫助解決問題,謝謝

lotustower

QUOTE:

以下是引用aborr在2006-10-29 20:15:32的发言：
在8樓的連結,發現我提的問題被高手收集了

剛剛 Mr. Excel 有類似的問題, 所以介紹給大家

lotustower

列出組合 1 (Jay Petrulis):

Option Explicit

Sub RunLottoSpecial()
    Call LottoSpecial(49, 101)
End Sub

Sub LottoSpecial(Num As Long, TargetVal As Long)
   
    Dim a As Integer, _
        b As Integer, _
        c As Integer, _
        d As Integer, _
        e As Integer, _
        f As Integer
   
    Dim Counter As Long, _
        NumCols As Long, _
        i As Long
   
    Dim arrResults
   
    Application.ScreenUpdating = False
   
    For a = 1 To Num - 5
        For b = a + 1 To Num - 4
            For c = b + 1 To Num - 3
                For d = c + 1 To Num - 2
                    For e = d + 1 To Num - 1
                        For f = e + 1 To Num
                            If a + b + c + d + e + f = TargetVal Then
                                Application.StatusBar = Counter
                                Counter = Counter + 1
                                With ActiveSheet
                                    If Counter Mod 65536 = 0 Then
                                        .Cells(65536, i + 1) = a & "," & b & "," & c & "," & d & "," & e & "," & f
                                        i = i + 1
                                    Else
                                        .Cells(Counter Mod 65536, i + 1) = a & "," & b & "," & c & "," & d & "," & e & "," & f
                                    End If
                                End With
                            End If
                        Next f
                    Next e
                Next d
            Next c
        Next b
    Next a
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub

lotustower

列出組合 2 (Output as Text File):

Sub MultipleLottoSums()
 
  Dim i As Long
  On Error GoTo Er
  Make_TextFile
  Open ActiveWorkbook.Path & "Report.txt" For Output As #1
        For i = 101 To 101   ' Change your Range (Depends on your PC)
           Application.StatusBar = "Finding combination ....Total sum = " & i
                Call LottoSpecial(49, i)
        Next i
           Application.StatusBar = ""
        Close #1
        MsgBox "Check text file .... " & ActiveWorkbook.Path & "\Report.txt"
Exit Sub
Er:
MsgBox "Error"
End Sub

Sub LottoSpecial(Num As Long, TargetVal As Long)
   
    Dim a As Integer, _
        b As Integer, _
        c As Integer, _
        d As Integer, _
        e As Integer, _
        f As Integer
   
    Dim Counter As Long, _
        NumCols As Long, _
        i As Long
    Dim arrResults
    Dim varTemp As String
   
    For a = 1 To Num - 5
        For b = a + 1 To Num - 4
            For c = b + 1 To Num - 3
                For d = c + 1 To Num - 2
                    For e = d + 1 To Num - 1
                        For f = e + 1 To Num
                            If a + b + c + d + e + f = TargetVal Then
                                       varTemp = a & "," & b & "," & c & "," & d & "," & e & "," & f
                                       Write #1, varTemp
                                       varTemp = ""
                            End If
                        Next f
                    Next e
                Next d
            Next c
        Next b
    Next a
End Sub
 
Sub Make_TextFile()
Open ActiveWorkbook.Path & "\Report.txt" For Output As #1
Close #1
End Sub

lotustower

 

'nMin = Sheets("Sheet1").Range("A1")
'nMax = Sheets("Sheet1").Range("A2")

Option Explicit

Sub LottoSpecial(Num As Long, TargetVal As Long)
   
    Dim a As Integer, _
        b As Integer, _
        c As Integer, _
        d As Integer, _
        e As Integer, _
        f As Integer
   
    Dim Counter As Long, _
        NumCols As Long, _
        i As Long
   
    Dim arrResults
   
    Application.ScreenUpdating = False
   
    For a = 1 To Num - 5
        For b = a + 1 To Num - 4
            For c = b + 1 To Num - 3
                For d = c + 1 To Num - 2
                    For e = d + 1 To Num - 1
                        For f = e + 1 To Num
                            If a + b + c + d + e + f = TargetVal Then
                                Application.StatusBar = Counter
                                Counter = Counter + 1
                                With ActiveSheet
                                    If Counter Mod 65536 = 0 Then
                                        .Cells(65536, i + 1) = a & "," & b & "," & c & "," & d & "," & e & "," & f
                                        i = i + 1
                                    Else
                                        .Cells(Counter Mod 65536, i + 1) = a & "," & b & "," & c & "," & d & "," & e & "," & f
                                    End If
                                End With
                            End If
                        Next f
                    Next e
                Next d
            Next c
        Next b
    Next a
    Application.StatusBar = False
    Application.ScreenUpdating = True
End Sub

Sub MultipleLottoSums()

    Dim nMin As Integer, _
        nMax As Integer

    Dim i As Long
   
    Dim Wks As Worksheet

    nMin = Sheets("Sheet1").Range("A1")
    nMax = Sheets("Sheet1").Range("A2")

    With ThisWorkbook
        For i = nMin To nMax
            Set Wks = .Worksheets.Add
            With Wks
                .Activate
                .Name = "Sum_to_" & i
                Call LottoSpecial(45, i)
            End With
        Next i
    End With
End Sub