Risolto ricerca doppio numero

Checco

Utente abituale
21 Aprile 2017
141
18
Torino
Excel 2016
0
Buonasera, nel file allegato ho provato a modificare la macro che cerca un doppio ambo nel quadro estrazionale, in una ricerca di un numero
doppio su due ruote consecutive, ma inutilmente e prima di combinare qualcosa di irreparabile chiedo il vostro aiuto per l'eventuale correzione.
In pratica, dovrebbe ricercare su due ruote consecutive, elencate nel foglio, un numero doppio, come nell'esempio salvato del 16/01/2021 su
Venezia-Nazionale con i numeri 38 e 73 e dopodichè portare 1 numero solamente in H5 e 1 numero solamente in H10, mantenendo le due ruote indicate in L5:M5.
Qualora sia possibile, inserire in I5:I6 i numeri sopra e sotto in corrispondenza del numero trovato e cioè, nel caso specifico il numero 73 (sotto il 38)
ed il numero 80 (sopra il 38) ed anche in H12:I12 il numero 38 (sopra il 73) ed il 4 (sotto il 73).
Spero di non aver creato confusione, ma nel caso sempre pronto a dare delucidazioni in merito.
Grazie anticipate :stringomano:
Checco
 

Allegati

karug64

Utente abituale
17 Gennaio 2021
404
30
Office 365
51
dopodichè portare 1 numero solamente in H5 e 1 numero solamente in H10
H10 o I5 ?
Qualora sia possibile, inserire in I5:I6 i numeri sopra e sotto in corrispondenza del numero trovato e cioè, nel caso specifico il numero 73 (sotto il 38)
ed il numero 80 (sopra il 38) ed anche in H12:I12 il numero 38 (sopra il 73) ed il 4 (sotto il 73).
Questo non mi è chiaro. Leggendo le ruote e trovando la coppia in Venezia e Nazionale tu non vuoi i numeri che si trovano sopra e sotto la coppia di Venezia (90-73 / 28-4) ?

E in caso di più coppie come ci si comporta ?


Ciao
 
  • Like
Reactions: Checco

Checco

Utente abituale
21 Aprile 2017
141
18
Torino
Excel 2016
0
Ciao Karug64, come nel caso che hai postato abbiamo il 4 sia su Cagliari che Firenze, quindi mi interesserebbe prendere i numeri 72 (sotto su Firenze) e 21 (sopra su Cagliari).
Stessa cosa per il 5 doppio si CA e FI, mi interesserà prendere il 44 (sopra su CA) e l'80 (sotto su FI).
Idem con i numeri 63 e 72 su Firenze e Genova, prendere l'84 (sotto su GE) ed il 5 (sopra su FI) e ugualmente il 38 (sotto su GE) e l'80 (sopra su FI).
Sperando che così sia più chiaro e comprensibile SmileFace
Checco
 

ges

Excel/VBA Expert
Amministratore
21 Giugno 2015
29.395
1.865
Como
2011MAC 365WIN
982
Ciao,
ci ho capito poco riguardo i numeri da estrarre, faccio un tentativo
Visual Basic:
Sub cerca_doppioni()
    Dim r As Integer
    Dim c As Integer
    Dim i As Integer
    Dim n1 As String
    Dim n2 As String
    Dim conta As Integer
    Dim numero As Integer
    Range("B5:F15").Interior.ColorIndex = xlNone
    r = 5: c = 2
    Do While r <= 14
        numero = Cells(r, c)
        For i = 2 To 6
            If numero = Cells(r + 1, i) Then
                conta = conta + 1
                If conta = 1 Then
                    n1 = Cells(r, c).Address
                    n2 = Cells(r + 1, i).Address
                End If
                If conta >= 2 Then
                    Cells(r, c).Interior.ColorIndex = 6
                    Cells(10, "H") = Cells(r, c)
                    Cells(11, "H") = Cells(r, c).Offset(1, -1)
                    Cells(11, "I") = Cells(r, c).Offset(1, 0)
                    Cells(r + 1, i).Interior.ColorIndex = 6
                    Range(n1).Interior.ColorIndex = 6
                    Cells(5, "H") = Range(n1)
                    Cells(6, "H") = Range(n1).Offset(, 1)
                    Cells(6, "I") = Range(n1).Offset(1, 0)
                    Range(n2).Interior.ColorIndex = 6
                End If
                Exit For
            End If
        Next i
        c = c + 1
        If c = 7 Then
            r = r + 1 :  c = 2
            conta = 0
        End If
    Loop
End Sub
 
  • Like
Reactions: Checco

karug64

Utente abituale
17 Gennaio 2021
404
30
Office 365
51
Ciao ges @ges posto anche la mia soluzione (sicuramente meno "pulita", ma sembra funzionare):

Visual Basic:
Sub ricerca2()
Dim d As String, r As String, sp As String, st As String
Dim n1 As Integer, n2 As Integer, x As Integer, y As Integer, z As Integer
Dim p1 As Integer
d = ""
r = ""
sp = ""
st = ""
n1 = 0
n2 = 0

For x = 5 To 15
    For y = x + 1 To 15
        For z = 2 To 6
            For zz = 2 To 6
                If y - x = 1 Then
                If Cells(x, z) = Cells(y, zz) Then
                    If Len(d) = 0 Then
                        d = Right("00" & Trim(Str(Cells(x, z))), 2)
                        sp = Right("00" & Trim(Str(Cells(x - 1, z))), 2)
                        st = Right("00" & Trim(Str(Cells(x + 1, z))), 2)
                        r = Trim(Cells(x, 1))
                    Else
                        d = d + "-" + Right("00" & Trim(Str(Cells(x, z))), 2)
                        sp = sp + "-" + Right("00" & Trim(Str(Cells(x - 1, z))), 2)
                        st = st + "-" + Right("00" & Trim(Str(Cells(x + 1, z))), 2)
                        r = r + "-" + Trim(Cells(y, 1))
                    End If
                End If
                End If
            Next zz
        Next z
        If Len(d) > 2 Then
            Range("H7") = Left(d, Len(d) - InStr(d, "-"))
            Range("I7") = Right(d, 2)
            Range("L7") = Mid(r, 1, (InStr(r, "-") - 1))
            Range("M7") = Mid(r, (InStr(r, "-") + 1), Len(r))
            n1 = Val(Left(d, Len(d) - InStr(d, "-")))
            n2 = Val(Right(d, 2))
                For p = 2 To 6
                    If Cells(x, p) = n1 Then
                       Range("H10") = Cells(x + 1, p).Value
                    End If
                    If Cells(y, p) = n1 Then
                        Range("I10") = Cells(y - 1, p).Value
                    End If
                    If Cells(x, p) = n2 Then
                       Range("H11") = Cells(x + 1, p).Value
                    End If
                    If Cells(y, p) = n2 Then
                        Range("I11") = Cells(y - 1, p).Value
                    End If
                Next p
                MsgBox "Trovata combinazione su ruote " & Str(n1) & " - " & Str(n2) & Chr(13) & "su ruote " & Mid(r, 1, (InStr(r, "-") - 1)) & " / " & Mid(r, (InStr(r, "-") + 1), Len(r))
                
            d = ""
            r = ""
            n1 = 0
            n2 = 0
            
        Else
            d = ""
            r = ""
            
        End If
    Next y
Next x
End Sub
 
  • Like
Reactions: Checco

Checco

Utente abituale
21 Aprile 2017
141
18
Torino
Excel 2016
0
Sub cerca_doppioni() Dim r As Integer Dim c As Integer Dim i As Integer Dim n1 As String Dim n2 As String Dim conta As Integer Dim numero As Integer Range("B5:F15").Interior.ColorIndex = xlNone r = 5 Do While r <= 14 numero = Cells(r, c) For i = 2 To 6 If numero = Cells(r + 1, i) Then conta = conta + 1 If conta = 1 Then n1 = Cells(r, c).Address n2 = Cells(r + 1, i).Address End If If conta >= 2 Then Cells(r, c).Interior.ColorIndex = 6 Cells(10, "H") = Cells(r, c) Cells(11, "H") = Cells(r, c).Offset(1, -1) Cells(11, "I") = Cells(r, c).Offset(1, 0) Cells(r + 1, i).Interior.ColorIndex = 6 Range(n1).Interior.ColorIndex = 6 Cells(5, "H") = Range(n1) Cells(6, "H") = Range(n1).Offset(, 1) Cells(6, "I") = Range(n1).Offset(1, 0) Range(n2).Interior.ColorIndex = 6 End If Exit For End If Next i c = c + 1 If c = 7 Then r = r + 1 : c = 2 conta = 0 End If Loop End Sub
Buonasera GES, purtroppo il tuo mi da un errore: "errore di run-time '1004' e precisamente alla riga: numero = Cells(r, c)
probabilmente sbaglio io qualcosa? Grazie.
Checco
 

Checco

Utente abituale
21 Aprile 2017
141
18
Torino
Excel 2016
0
Sub ricerca2() Dim d As String, r As String, sp As String, st As String Dim n1 As Integer, n2 As Integer, x As Integer, y As Integer, z As Integer Dim p1 As Integer d = "" r = "" sp = "" st = "" n1 = 0 n2 = 0 For x = 5 To 15 For y = x + 1 To 15 For z = 2 To 6 For zz = 2 To 6 If y - x = 1 Then If Cells(x, z) = Cells(y, zz) Then If Len(d) = 0 Then d = Right("00" & Trim(Str(Cells(x, z))), 2) sp = Right("00" & Trim(Str(Cells(x - 1, z))), 2) st = Right("00" & Trim(Str(Cells(x + 1, z))), 2) r = Trim(Cells(x, 1)) Else d = d + "-" + Right("00" & Trim(Str(Cells(x, z))), 2) sp = sp + "-" + Right("00" & Trim(Str(Cells(x - 1, z))), 2) st = st + "-" + Right("00" & Trim(Str(Cells(x + 1, z))), 2) r = r + "-" + Trim(Cells(y, 1)) End If End If End If Next zz Next z If Len(d) > 2 Then Range("H7") = Left(d, Len(d) - InStr(d, "-")) Range("I7") = Right(d, 2) Range("L7") = Mid(r, 1, (InStr(r, "-") - 1)) Range("M7") = Mid(r, (InStr(r, "-") + 1), Len(r)) n1 = Val(Left(d, Len(d) - InStr(d, "-"))) n2 = Val(Right(d, 2)) For p = 2 To 6 If Cells(x, p) = n1 Then Range("H10") = Cells(x + 1, p).Value End If If Cells(y, p) = n1 Then Range("I10") = Cells(y - 1, p).Value End If If Cells(x, p) = n2 Then Range("H11") = Cells(x + 1, p).Value End If If Cells(y, p) = n2 Then Range("I11") = Cells(y - 1, p).Value End If Next p MsgBox "Trovata combinazione su ruote " & Str(n1) & " - " & Str(n2) & Chr(13) & "su ruote " & Mid(r, 1, (InStr(r, "-") - 1)) & " / " & Mid(r, (InStr(r, "-") + 1), Len(r)) d = "" r = "" n1 = 0 n2 = 0 Else d = "" r = "" End If Next y Next x End Sub
buonasera Karug64, ti ringrazio per questa tua soluzione, anche se trova SOLO i doppi numeri su due ruote consecutive, mentre io intendevo ricercare ANCHE 1 solo numero doppio su due ruote consecutive. Pensi sia possibile? Grazie mille.
Checco
 

karug64

Utente abituale
17 Gennaio 2021
404
30
Office 365
51
Non so se è fattibile o meno, ma la richiesta mi sembra non parlasse di un numero solo. I tuoi esempi riportano solo coppie di numeri (almeno credo).....
Inoltre, resta sempre il dubbio di come rappresentare gli eventuali risultati in considerazione che le celle dove chiedi i risultati sono sempre le stesse H5 e I5 ma gli ambi uguali su ruote consecutive (e a maggior ragione i numeri singoli su ruote consecutive) possono essere più di uno, nel qual caso i risultati andrebbero ricoperti .....
 

Checco

Utente abituale
21 Aprile 2017
141
18
Torino
Excel 2016
0
Non so se è fattibile o meno, ma la richiesta mi sembra non parlasse di un numero solo. I tuoi esempi riportano solo coppie di numeri (almeno credo).....
Inoltre, resta sempre il dubbio di come rappresentare gli eventuali risultati in considerazione che le celle dove chiedi i risultati sono sempre le stesse H5 e I5 ma gli ambi uguali su ruote consecutive (e a maggior ragione i numeri singoli su ruote consecutive) possono essere più di uno, nel qual caso i risultati andrebbero ricoperti .....

Ciao Karug64, mi scuso se ho fatto un esempio sbagliato, a me interesserebbe trovare un solo numero doppio, poi è evidente che se in un'estrazione ce ne sono più di uno, va bene lo stesso.
Checco
 

karug64

Utente abituale
17 Gennaio 2021
404
30
Office 365
51
Quindi tu non cerchi gli ambi su ruota consecutive ma solo gli estratti

E continuo a chiedere, anche per gli altri che seguono, i risultati come dovrebbero essere esposti ?
 
  • Like
Reactions: Checco

Checco

Utente abituale
21 Aprile 2017
141
18
Torino
Excel 2016
0
Ciao,
ci ho capito poco riguardo i numeri da estrarre, faccio un tentativo
Visual Basic:
Sub cerca_doppioni()
    Dim r As Integer
    Dim c As Integer
    Dim i As Integer
    Dim n1 As String
    Dim n2 As String
    Dim conta As Integer
    Dim numero As Integer
    Range("B5:F15").Interior.ColorIndex = xlNone
    r = 5: c = 2
    Do While r <= 14
        numero = Cells(r, c)
        For i = 2 To 6
            If numero = Cells(r + 1, i) Then
                conta = conta + 1
                If conta = 1 Then
                    n1 = Cells(r, c).Address
                    n2 = Cells(r + 1, i).Address
                End If
                If conta >= 2 Then
                    Cells(r, c).Interior.ColorIndex = 6
                    Cells(10, "H") = Cells(r, c)
                    Cells(11, "H") = Cells(r, c).Offset(1, -1)
                    Cells(11, "I") = Cells(r, c).Offset(1, 0)
                    Cells(r + 1, i).Interior.ColorIndex = 6
                    Range(n1).Interior.ColorIndex = 6
                    Cells(5, "H") = Range(n1)
                    Cells(6, "H") = Range(n1).Offset(, 1)
                    Cells(6, "I") = Range(n1).Offset(1, 0)
                    Range(n2).Interior.ColorIndex = 6
                End If
                Exit For
            End If
        Next i
        c = c + 1
        If c = 7 Then
            r = r + 1 :  c = 2
            conta = 0
        End If
    Loop
End Sub

Buonasera GES, adesso sembra funzionare, però i numeri da ricavare sono errati. Ti allego il file con i numeri trovati dal tuo VBA e nello stesso file ti coloro diversamente i numeri da ricavare. E se fosse possibile la ricerca del solo estratto doppio. Grazie x l'impegno :StrettaDiMano:
Checco
 

Allegati

Ultima modifica:

karug64

Utente abituale
17 Gennaio 2021
404
30
Office 365
51
Puoi provare così:

Visual Basic:
Sub ricerca3()
Dim x As Integer, y As Integer, z As Integer, zz As Integer

For x = 5 To 15
    For y = x + 1 To 15
        For z = 2 To 6
            For zz = 2 To 6
                If y - x = 1 Then
                    If Cells(x, z) = Cells(y, zz) Then
                        Cells(x, z).Interior.ColorIndex = 27
                        Cells(y, zz).Interior.ColorIndex = 27
                        Range("H7") = Cells(x, z)
                        Range("L7") = Cells(x, 1)
                        Range("M7") = Cells(y, 1)
                        Range("H10") = Cells(y, z)
                        Range("I10") = Cells(x, zz)
                        MsgBox "Su ruote " & Cells(x, 1) & " - " & Cells(y, 1) & " trovato l'estratto comune: " & Str(Cells(x, z)) _
                        & Chr(13) & Chr(13) & "Sotto il " & Str(Cells(x, z)) & " = " & Str(Cells(y, z)) _
                        & Chr(13) & "Sopra il " & Str(Cells(x, z)) & " = " & Str(Cells(x, zz))
                        Cells(x, z).Interior.ColorIndex = 2
                        Cells(y, zz).Interior.ColorIndex = 2
                    End If
                End If
            Next zz
        Next z
    Next y
Next x
End Sub
Ciao
 
  • Like
Reactions: Checco

Checco

Utente abituale
21 Aprile 2017
141
18
Torino
Excel 2016
0
Puoi provare così:

Visual Basic:
Sub ricerca3()
Dim x As Integer, y As Integer, z As Integer, zz As Integer

For x = 5 To 15
    For y = x + 1 To 15
        For z = 2 To 6
            For zz = 2 To 6
                If y - x = 1 Then
                    If Cells(x, z) = Cells(y, zz) Then
                        Cells(x, z).Interior.ColorIndex = 27
                        Cells(y, zz).Interior.ColorIndex = 27
                        Range("H7") = Cells(x, z)
                        Range("L7") = Cells(x, 1)
                        Range("M7") = Cells(y, 1)
                        Range("H10") = Cells(y, z)
                        Range("I10") = Cells(x, zz)
                        MsgBox "Su ruote " & Cells(x, 1) & " - " & Cells(y, 1) & " trovato l'estratto comune: " & Str(Cells(x, z)) _
                        & Chr(13) & Chr(13) & "Sotto il " & Str(Cells(x, z)) & " = " & Str(Cells(y, z)) _
                        & Chr(13) & "Sopra il " & Str(Cells(x, z)) & " = " & Str(Cells(x, zz))
                        Cells(x, z).Interior.ColorIndex = 2
                        Cells(y, zz).Interior.ColorIndex = 2
                    End If
                End If
            Next zz
        Next z
    Next y
Next x
End Sub
Ciao
Fantastico!!!!....proprio quello che volevo io :stringomano:
grazie mille
Checco
 

Checco

Utente abituale
21 Aprile 2017
141
18
Torino
Excel 2016
0
Puoi provare così:

Visual Basic:
Sub ricerca3()
Dim x As Integer, y As Integer, z As Integer, zz As Integer

For x = 5 To 15
    For y = x + 1 To 15
        For z = 2 To 6
            For zz = 2 To 6
                If y - x = 1 Then
                    If Cells(x, z) = Cells(y, zz) Then
                        Cells(x, z).Interior.ColorIndex = 27
                        Cells(y, zz).Interior.ColorIndex = 27
                        Range("H7") = Cells(x, z)
                        Range("L7") = Cells(x, 1)
                        Range("M7") = Cells(y, 1)
                        Range("H10") = Cells(y, z)
                        Range("I10") = Cells(x, zz)
                        MsgBox "Su ruote " & Cells(x, 1) & " - " & Cells(y, 1) & " trovato l'estratto comune: " & Str(Cells(x, z)) _
                        & Chr(13) & Chr(13) & "Sotto il " & Str(Cells(x, z)) & " = " & Str(Cells(y, z)) _
                        & Chr(13) & "Sopra il " & Str(Cells(x, z)) & " = " & Str(Cells(x, zz))
                        Cells(x, z).Interior.ColorIndex = 2
                        Cells(y, zz).Interior.ColorIndex = 2
                    End If
                End If
            Next zz
        Next z
    Next y
Next x
End Sub
Ciao
Fantastico!!!!....proprio quello che volevo io :stringomano:
grazie mille
Checco

Se non chiedo troppo, sarebbe possibile non far vedere i vari risultati con il MsgBox, ma icolonnarli in H:I specificando sempre le ruote di provenienza? Grazie mille ancora.
Checco
 

karug64

Utente abituale
17 Gennaio 2021
404
30
Office 365
51
Prova così:
Visual Basic:
Sub ricerca3()
Dim x As Integer, y As Integer, z As Integer, zz As Integer, r As Integer
r = 6
For x = 5 To 15
    For y = x + 1 To 15
        For z = 2 To 6
            For zz = 2 To 6
                If y - x = 1 Then
                    If Cells(x, z) = Cells(y, zz) Then
                        r = r + 1
                        Cells(r, 8) = Cells(x, z)
                        Cells(r, 9) = Cells(y, z)
                        Cells(r, 10) = Cells(x, zz)
                        Cells(r, 12) = Cells(x, 1)
                        Cells(r, 13) = Cells(y, 1)
                    End If
                End If
            Next zz
        Next z
    Next y
Next x
End Sub
Ciao
 

Checco

Utente abituale
21 Aprile 2017
141
18
Torino
Excel 2016
0
Prova così:
Visual Basic:
Sub ricerca3()
Dim x As Integer, y As Integer, z As Integer, zz As Integer, r As Integer
r = 6
For x = 5 To 15
    For y = x + 1 To 15
        For z = 2 To 6
            For zz = 2 To 6
                If y - x = 1 Then
                    If Cells(x, z) = Cells(y, zz) Then
                        r = r + 1
                        Cells(r, 8) = Cells(x, z)
                        Cells(r, 9) = Cells(y, z)
                        Cells(r, 10) = Cells(x, zz)
                        Cells(r, 12) = Cells(x, 1)
                        Cells(r, 13) = Cells(y, 1)
                    End If
                End If
            Next zz
        Next z
    Next y
Next x
End Sub
Ciao

Sei un grande Karug64 :applausi:
Checco
 

Sostieni ForumExcel

Aiutaci a sostenere le spese e a mantenere online la community attraverso una libera donazione!