hi again,
i was still happy for your solution........
and I have test it many time.......
don't call me rude if ask another 4 question :
1)
i've have tried to select only 14 of my 32 (based number)
and as you Newton Binomio say this :
n!
__________
K!(n-K)!
so if you take 14 number for "Setsof8" do you have :
Max 3.003 combination !
infact in results of vba code Generate5000Setsof8 we have some rows
duplicate
is possibile not generate it ?
2)
is possible have a "volatile" selection of based number, in sense :
one time i select 20 of my 32 based number
one time i select 15 of my 32 based number
one time i select 18 of my 32 based number
3)
I see many row in your code that begin with : '
are all comments ?
or is happened something in your copy and past ?
4)
how many time of your life have you spend for learn vba code as well ?????
I have also to grate you...and don't spend more time for
me.......****please*****......
if my question is hard to solve don't worry....i traspose all in access and
delete
duplicate record.
many thank for your attention.
I post the code that i have arranged, so you can understand more clear
(perhaps)
what i have tried to explain in my 2 question.
Application.ScreenUpdating = False
Dim riga As Range
Dim OutRange As Range
Set OutRange = [P2:W5000]
Range("AC1:AJ32").Select
Range("AJ32").Activate
Selection.ClearContents
Range("B1:B32,E1:E32,J1:J32").Select
Range("J1").Activate
Selection.Copy
Range("AD1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone,
SkipBlanks _
:=False, Transpose:=False
Range("AD1:AF32").Select
Range("AF1").Activate
Application.CutCopyMode = False
Selection.Sort Key1:=Range("AF1"), Order1:=xlDescending, Header:=xlGuess
_
, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Range("AD1:AF1").Select
Selection.AutoFilter
Selection.AutoFilter Field:=3, Criteria1:="FALSO"
Range("AD1:AF32").Select
Selection.ClearContents
Range("AE21").Select
Selection.FormulaR1C1 = "=SUM(R[-19]C:R[-1]C)"
Range("AG2").Select
ActiveCell.FormulaR1C1 = "=+RC[-2]/R21C31"
Range("AG2").Select
Selection.AutoFill Destination:=Range("AG2:AG15"), Type:=xlFillDefault
Range("AG2:AG15").Select
Range("AE21").Select
Selection.Cut Destination:=Range("AE1")
Range("AI2").Select
ActiveCell.FormulaR1C1 = "=+RC[-5]"
Range("AJ2").Select
ActiveCell.FormulaR1C1 = "=+RC[-3]"
Range("AI2:AJ2").Select
Selection.AutoFill Destination:=Range("AI2:AJ32"), Type:=xlFillDefault
Range("AI2:AJ15").Select
Application.Run "Generate5000Setsof8"
Range("P2:W5000").Select
For Each riga In Selection.Rows
riga.Sort Key1:=riga.Cells(1), Order1:=xlAscending, Header:=xlNo, _
Orientation:=xlLeftToRight
Next
End Sub
Sub Generate5000Setsof8()
Dim dist As Variant, distA As Variant
Dim dist1 As Variant
Dim sNum As Single
Dim ll As Long, i As Long, j As Long
Dim rnum(1 To 8) As Variant
Application.Calculation = xlManual
Randomize Time
dist = Range("AI1:AJ15")
Dim rng As Range
Set rng = Range("P2")
For ll = 1 To 5000
For i = 1 To 8
If i = 1 Then
dist = Range("AI1:AJ15")
dist1 = BuildCum(dist)
Else
If i = 2 Then
distA = BuildDist(dist)
Else
distA = BuildDist(distA)
End If
' Debug.Print i, TypeName(distA)
' Debug.Print LBound(distA, 1), UBound(distA, 1), LBound(distA, 2),
' UBound(distA, 2)
dist1 = BuildCum(distA)
End If
' If i = 1 Then
' Range("AK1:AK32").Value = Application.Transpose(dist1)
' Else
' Range("Ai1").Offset(0, i * 3 - 2).Resize(UBound(distA, 1) -
'LBound(distA, 1) _
' + 1, UBound(distA, 2) - LBound(distA, 2) + 1).Value = _
' distA
' Range("Ai1").Offset(0, i * 3).Resize(UBound(dist1, 1) - LBound(dist1, 1)
'+ 1, 1) _
' .Value = Application.Transpose(dist1)
' End If
sNum = Rnd
For j = LBound(dist1) To UBound(dist1)
' Debug.Print j, snum, dist1(j)
If sNum <= dist1(j) Then
If i = 1 Then
rnum(i) = dist(j, LBound(dist, 2))
dist(j, LBound(dist, 2)) = 0
' Debug.Print "item: " & j
Else
rnum(i) = distA(j, LBound(distA, 2))
distA(j, LBound(distA, 2)) = 0
' Debug.Print "Item: " & j
End If
Exit For
End If
Next j
Next i
'For kl = 1 To 8
' Debug.Print rnum(kl);
'Next
Range("p2").Offset(ll - 1, 0).Resize(1, 8).Value = rnum
Next ll
Application.Calculation = xlAutomatic
End Sub
Function BuildDist(varr)
Dim distA() As Variant
Dim tot As Double
'Debug.Print "Builddist", LBound(varr, 1), UBound(varr, 1), _
' LBound(varr, 2), UBound(varr, 2)
Dim i As Long, j As Long, k As Long
ReDim distA(LBound(varr, 1) To UBound(varr, 1) - 1, _
LBound(varr, 2) To UBound(varr, 2))
i = LBound(varr, 1)
For j = i To UBound(varr, 1)
If varr(j, LBound(varr, 2)) <> 0 Then
For k = LBound(varr, 2) To UBound(varr, 2)
distA(i, k) = varr(j, k)
Next
tot = tot + distA(i, UBound(varr, 2))
i = i + 1
End If
Next
For j = LBound(distA, 1) To UBound(distA, 1)
distA(j, UBound(distA, 2)) = _
(distA(j, UBound(distA, 2)) / tot)
Next
BuildDist = distA
End Function
Function BuildCum(varr) As Variant
Dim dist1()
Dim i As Long
ReDim dist1(LBound(varr, 1) To UBound(varr, 1))
For i = LBound(dist1) To UBound(dist1)
If i = LBound(dist1) Then
dist1(i) = varr(i, UBound(varr, 2))
Else
dist1(i) = dist1(i - 1) + varr(i, UBound(varr, 2))
End If
Next
'Debug.Print "Cum: " & dist1(UBound(dist1, 1))
BuildCum = dist1
End Function
......i was thinking that wasn't the best but a my