Una premessa, è da poco tempo che mi sto cimentando nelle macro di Excel.
Il mio problema per cui chiedo aiuto è il seguente: ho una macro, che mi combina 50 numeri in cinquine tenendo conto di alcune condizioni pertanto scrive solo le combinazioni specifiche. Siccome la macro combina i numeri in orizzontale, quindi terminate le colonne del foglio si ferma dandomi l'errore.
Chiedo a voi se c'è una possibilità che le combinazioni, quindi senza fermare la routine, possano continuare nelle colonne dei fogli successivi. Ho provato di tutto ma senza risultati, ma ricordo che non sono un esperto e ho da poco iniziato. La macro è la seguente, se devo allegare il file ditemi come devo fare.
- Codice: Seleziona tutto
Sub startSearch()
If Range("C1") = "" Then
MsgBox "Inserire in C1 il numero degli addendi desiderati" & vbCrLf & _
"Se si vogliono tutte le soluzioni inserire 999"
Exit Sub
End If
Range("D1:XFD25").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, "", ", "
drow = 1: dcol = 4
'-----------------PARTE MODIFICATA--------------------->
Dim NumRighe As Integer
Dim mySheets As Worksheet
NumRighe = 0
For J = 0 To UBound(Rslt)
If Range("C1") < 999 Then
quanti = Len(Rslt(J)) - Len(Replace(Rslt(J), ",", "")) + 1
If quanti > NumRighe Then NumRighe = quanti
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
Else
quanti = Len(Rslt(J)) - Len(Replace(Rslt(J), ",", "")) + 1
If quanti > NumRighe Then NumRighe = quanti
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
For Each mySheets In Worksheets(5)
mySheets.Select
mySheets.Application.Run
Next mySheets
End If
Next
PariDispariFasce
'<-------------------------------------------------------
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)
If MaxSoln = 0 Then
'
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
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
Sub EliminaColonne()
Dim d As Integer
uc = Range("D1").End(xlToRight).Column
ur = 20
dacanc = Range("C2").Value
k = InStr(dacanc, "#")
If k > 0 Then
If k = 1 Then '= #n, elimina solo dispari corrispondenti
dacanc = Right(dacanc, 1) * 1
For c = uc To 4 Step -1
d = (Cells(20, c) - Int(Cells(20, c))) * 10
If d = dacanc Then
Columns(c).Delete Shift:=xlToLeft
End If
Next c
ElseIf k = 2 Then '= n#, elimina solo pari corrispondenti
dacanc = Left(dacanc, 1) * 1
For c = uc To 4 Step -1
If Int(Cells(20, c)) = dacanc Then
Columns(c).Delete Shift:=xlToLeft
End If
Next c
Else ' altri casi non previsti
MsgBox "Valori non previsti dalla routine. Elaborazione interrotta"
Exit Sub
End If
End If
For c = uc To 4 Step -1
If Cells(20, c) = dacanc Then
Columns(c).Delete Shift:=xlToLeft
End If
Next c
End Sub
Sub PariDispariFasce()
If Range("D1") = "" Then Exit Sub
uc = Range("D1").End(xlToRight).Column
r1 = 20
For c = 4 To uc
p = 0
d = 0
f1 = 0
f2 = 0
f3 = 0
ur = Cells(1, c).End(xlDown).Row
If ur = Rows.Count Then ur = 1
For r = 1 To ur
If Cells(r, c) Mod 2 = 0 Then
p = p + 1
Else
d = d + 1
End If
Select Case Cells(r, c)
Case Is <= 16
f1 = f1 + 1
Case Is <= 33
f2 = f2 + 1
Case Is <= 50
f3 = f3 + 1
End Select
Next r
Cells(r1, c) = p & "." & d
Cells(r1 + 1, c) = f1 & "." & f2 & "." & f3
Next c
End Sub
Sub EliminaFasce()
uc = Range("D1").End(xlToRight).Column
ur = 20
dacanc = Range("C3").Value
For c = uc To 4 Step -1
If Cells(21, c) = dacanc Then
Columns(c).Delete Shift:=xlToLeft
End If
Next c
End Sub
Grazie a chi vorrà aiutarmi.
Antonio
