Ciao Elgambero, eccoti la Macro
- Codice: Seleziona tutto
Sub estrai()
Dim r, c, d, x, y, n, k, risp, arr1, arr2, arrA
arr1 = Range("B1:F1")
arr2 = Range("B2:F2")
Range("B5:K20").ClearContents
r = 5: c = 2
For x = 1 To 5
For y = x + 1 To 5
d = arr1(1, x) + arr1(1, y)
If d > 90 Then d = d - 90
Cells(r, c) = d
c = c + 1
Next y
Next x
r = 6: c = 2
For x = 1 To 5
For y = x + 1 To 5
d = arr2(1, x) + arr2(1, y)
If d > 90 Then d = d - 90
Cells(r, c) = d
c = c + 1
Next y
Next x
r = 9: c = 2
For x = 2 To 11
If Cells(5, x) = Cells(6, x) Then
Select Case x
Case 2
Cells(r, c) = arr1(1, 1): Cells(r, c + 1) = arr1(1, 2): Cells(r, c + 2) = arr2(1, 1): Cells(r, c + 3) = arr2(1, 2)
Case 3
Cells(r, c) = arr1(1, 1): Cells(r, c + 1) = arr1(1, 3): Cells(r, c + 2) = arr2(1, 1): Cells(r, c + 3) = arr2(1, 3)
Case 4
Cells(r, c) = arr1(1, 1): Cells(r, c + 1) = arr1(1, 4): Cells(r, c + 2) = arr2(1, 1): Cells(r, c + 3) = arr2(1, 4)
Case 5
Cells(r, c) = arr1(1, 1): Cells(r, c + 1) = arr1(1, 5): Cells(r, c + 2) = arr2(1, 1): Cells(r, c + 3) = arr2(1, 5)
Case 6
Cells(r, c) = arr1(1, 2): Cells(r, c + 1) = arr1(1, 3): Cells(r, c + 2) = arr2(1, 2): Cells(r, c + 3) = arr2(1, 3)
Case 7
Cells(r, c) = arr1(1, 2): Cells(r, c + 1) = arr1(1, 4): Cells(r, c + 2) = arr2(1, 2): Cells(r, c + 3) = arr2(1, 4)
Case 8
Cells(r, c) = arr1(1, 2): Cells(r, c + 1) = arr1(1, 5): Cells(r, c + 2) = arr2(1, 2): Cells(r, c + 3) = arr2(1, 5)
Case 9
Cells(r, c) = arr1(1, 3): Cells(r, c + 1) = arr1(1, 4): Cells(r, c + 2) = arr2(1, 3): Cells(r, c + 3) = arr2(1, 4)
Case 10
Cells(r, c) = arr1(1, 3): Cells(r, c + 1) = arr1(1, 5): Cells(r, c + 2) = arr2(1, 3): Cells(r, c + 3) = arr2(1, 5)
Case 11
Cells(r, c) = arr1(1, 4): Cells(r, c + 1) = arr1(1, 5): Cells(r, c + 2) = arr2(1, 4): Cells(r, c + 3) = arr2(1, 5)
End Select
r = r + 1
End If
Next x
If Range("B9") = "" Then
risp = MsgBox("Controllo se ci sono corrispondenze tra le due serie?", vbInformation + vbYesNo, "Controllo corrispondenze")
If risp = 7 Then Exit Sub
k = 5
r = 9
Set arrA = Range("B6:K6")
For x = 2 To 11
d = Cells(k, x)
n = WorksheetFunction.CountIf(arrA, d)
If n > 0 Then
Select Case x
Case 2
Cells(r, c) = arr1(1, 1): Cells(r, c + 1) = arr1(1, 2)
Case 3
Cells(r, c) = arr1(1, 1): Cells(r, c + 1) = arr1(1, 3)
Case 4
Cells(r, c) = arr1(1, 1): Cells(r, c + 1) = arr1(1, 4)
Case 5
Cells(r, c) = arr1(1, 1): Cells(r, c + 1) = arr1(1, 5)
Case 6
Cells(r, c) = arr1(1, 2): Cells(r, c + 1) = arr1(1, 3)
Case 7
Cells(r, c) = arr1(1, 2): Cells(r, c + 1) = arr1(1, 4)
Case 8
Cells(r, c) = arr1(1, 2): Cells(r, c + 1) = arr1(1, 5)
Case 9
Cells(r, c) = arr1(1, 3): Cells(r, c + 1) = arr1(1, 4)
Case 10
Cells(r, c) = arr1(1, 3): Cells(r, c + 1) = arr1(1, 5)
Case 11
Cells(r, c) = arr1(1, 4): Cells(r, c + 1) = arr1(1, 5)
End Select
For y = 2 To 11
If d = Cells(k + 1, y) Then
Select Case y
Case 2
Cells(r, c + 2) = arr2(1, 1): Cells(r, c + 3) = arr2(1, 2)
Case 3
Cells(r, c + 2) = arr2(1, 1): Cells(r, c + 3) = arr2(1, 3)
Case 4
Cells(r, c + 2) = arr2(1, 1): Cells(r, c + 3) = arr2(1, 4)
Case 5
Cells(r, c + 2) = arr2(1, 1): Cells(r, c + 3) = arr2(1, 5)
Case 6
Cells(r, c + 2) = arr2(1, 2): Cells(r, c + 3) = arr2(1, 3)
Case 7
Cells(r, c + 2) = arr2(1, 2): Cells(r, c + 3) = arr2(1, 4)
Case 8
Cells(r, c + 2) = arr2(1, 2): Cells(r, c + 3) = arr2(1, 5)
Case 9
Cells(r, c + 2) = arr2(1, 3): Cells(r, c + 3) = arr2(1, 4)
Case 10
Cells(r, c + 2) = arr2(1, 3): Cells(r, c + 3) = arr2(1, 5)
Case 11
Cells(r, c + 2) = arr2(1, 4): Cells(r, c + 3) = arr2(1, 5)
End Select
If n > 1 Then
Cells(r + 1, c) = Cells(r, c): Cells(r + 1, c + 1) = Cells(r, c + 1)
r = r + 1
Else
Exit For
End If
End If
Next y
r = r + 1
End If
Next x
End If
Set arrA = Nothing
End Sub
in effetti avevo previsto che ci potessero essere più combinazioni,
ma per le estrazioni successive, si dovrebbe usare un altro sistema, però adesso se le inserisci manualmente funziona lo stesso
ti allego anche il file, questo il link
https://www.dropbox.com/s/otjsrfhgitdaq ... .xlsm?dl=0fai copia incolla della serie "AF1:AJ2" in B1
in quelle estrazioni ci sono 3 serie di numeri anche se non opponibili, cioè nelle stesse posizioni.
ti da un avviso se non trova numeri opponibili per continuare.
Ciao By Sal (8-D
per lanciare la macro fai click sul calamaio