Ciao PFCA, grazie per la celere risposta, allora, ho cercato di mettere il file .xlms ma non lo accetta quindi ti copio la macro che serve per determinare le combinazioni secondo la somma della sestina che io gli do combinando una serie di numeri e gli chiedo anche quanti devono essere gli addendi, in questo caso 6 ma possono essere diversi, per il superenalotto 6. mi da X combinazioni che sono in colonne, per cui io non so quante colonne sono, diciamo che sono il max delle colonne. Poi con una formula ho determinato il numero dei dispari. I 28 numeri sono digitati nella colonna B3-B30. Lo sviluppo va da D1 a XFD6. La somma è indicata in B2. Gli addendi da combinare in C1, mentre il numero di combinazioni date in A7.
Se puoi inserisci il tutto in questa macro, in modo da riscriverla tutta insieme.
Sub startSearch()
'The selection should be a single contiguous range in a single column. _
The first cell indicates the number of solutions wanted. Specify zero for all. _
The 2nd cell is the target value. _
The rest of the cells are the values available for matching. _
The output is in the column adjacent to the one containing the input data.
If Range("C1") = "" Then
MsgBox "Inserire in C1 il numero degli addendi desiderati"
Exit Sub
End If
Range("D1:XFD6").ClearContents
LR = Cells(Rows.Count, "B").End(xlUp).Row
Range("B1:B" & LR).Select
If Not TypeOf Selection Is Range Then GoTo ErrXIT
If Selection.Areas.Count > 1 Or Selection.Columns.Count > 1 Then GoTo ErrXIT
If Selection.Rows.Count < 3 Then GoTo ErrXIT
Dim TargetVal, Rslt(), InArr(), StartTime As Date, MaxSoln As Integer, _
HaveRandomNegatives As Boolean
StartTime = Now()
MaxSoln = Selection.Cells(1).Value
TargetVal = Selection.Cells(2).Value
InArr = Application.WorksheetFunction.Transpose( _
Selection.Offset(2, 0).Resize(Selection.Rows.Count - 2).Value)
HaveRandomNegatives = checkRandomNegatives(InArr)
If Not HaveRandomNegatives Then
ElseIf MsgBox("At least 1 negative number is present between positive numbers" _
& vbNewLine _
& "It may take a lot longer to search for matches." & vbNewLine _
& "OK to continue else Cancel", vbOKCancel) = vbCancel Then
Exit Sub
End If
ReDim Rslt(0)
recursiveMatch MaxSoln, TargetVal, InArr, HaveRandomNegatives, _
LBound(InArr), 0, 0.00000001, _
Rslt, "", ", "
'Rslt(UBound(Rslt)) = Format(Now, "hh:mm:ss")
'ReDim Preserve Rslt(UBound(Rslt) + 1)
'Rslt(UBound(Rslt)) = Format(StartTime, "hh:mm:ss")
'Selection.Offset(0, 1).Resize(ArrLen(Rslt), 1).Value = _
Application.WorksheetFunction.Transpose(Rslt)
drow = 1: dcol = 4
'----------------PARTE MODIFICATA--------------------->
For J = 0 To UBound(Rslt)
quanti = Len(Rslt(J)) - Len(Replace(Rslt(J), ",", "")) + 1
If quanti = Range("C1") Then
arr0 = Split(Rslt(J), ",")
For I = 0 To UBound(arr0)
Cells(drow, dcol) = Cells(arr0(I) + 2, 2)
drow = drow + 1
Next
dcol = dcol + 1
drow = 1
End If
Next
'<-------------------------------------------------------
Exit Sub
ErrXIT:
MsgBox "Please select cells in a single column before using this macro" & vbNewLine _
& "The selection should be a single contiguous range in a single column." & vbNewLine _
& "The first cell indicates the number of solutions wanted. Specify zero for all." & vbNewLine _
& "The 2nd cell is the target value." & vbNewLine _
& "The rest of the cells are the values available for matching." & vbNewLine _
& "The output is in the column adjacent to the one containing the input data."
End Sub
Function RealEqual(A, B, Optional Epsilon As Double = 0.00000001)
RealEqual = Abs(A - B) <= Epsilon
End Function
Function ExtendRslt(CurrRslt, NewVal, Separator)
If CurrRslt = "" Then ExtendRslt = NewVal _
Else ExtendRslt = CurrRslt & Separator & NewVal
End Function
Sub recursiveMatch(ByVal MaxSoln As Integer, ByVal TargetVal, InArr(), _
ByVal HaveRandomNegatives As Boolean, _
ByVal CurrIdx As Integer, _
ByVal CurrTotal, ByVal Epsilon As Double, _
ByRef Rslt(), ByVal CurrRslt As String, ByVal Separator As String)
Dim I As Integer
For I = CurrIdx To UBound(InArr)
If RealEqual(CurrTotal + InArr(I), TargetVal, Epsilon) Then
Rslt(UBound(Rslt)) = ExtendRslt(CurrRslt, I, Separator)
'Rslt(UBound(Rslt)) = (CurrTotal + InArr(I)) _
& Separator & ExtendRslt(CurrRslt, I, Separator)
If MaxSoln = 0 Then
' If UBound(Rslt) Mod 100 = 0 Then Debug.Print "Rslt(" & UBound(Rslt) & ")=" & Rslt(UBound(Rslt))
Else
If UBound(Rslt) >= MaxSoln Then Exit Sub
End If
ReDim Preserve Rslt(UBound(Rslt) + 1)
ElseIf IIf(HaveRandomNegatives, False, CurrTotal + InArr(I) > TargetVal + Epsilon) Then
ElseIf CurrIdx < UBound(InArr) Then
recursiveMatch MaxSoln, TargetVal, InArr(), HaveRandomNegatives, _
I + 1, _
CurrTotal + InArr(I), Epsilon, Rslt(), _
ExtendRslt(CurrRslt, I, Separator), _
Separator
If MaxSoln <> 0 Then If UBound(Rslt) >= MaxSoln Then Exit Sub
Else
'we've run out of possible elements and we _
still don't have a match
End If
Next I
End Sub
Function ArrLen(Arr()) As Integer
On Error Resume Next
ArrLen = UBound(Arr) - LBound(Arr) + 1
End Function
Function checkRandomNegatives(Arr) As Boolean
Dim I As Long
I = LBound(Arr)
Do While Arr(I) < 0 And I < UBound(Arr): I = I + 1: Loop
If I = UBound(Arr) Then Exit Function
Do While Arr(I) >= 0 And I < UBound(Arr): I = I + 1: Loop
checkRandomNegatives = Arr(I) < 0
End Function
