Risolto cambio colori

Checco

Utente junior
21 Aprile 2017
55
8
Torino
Excel 2016
0
Buongiorno, nel file allegato c'è una macro per la ricerca di un ambo doppio nel quadro estrazionale B5:G15
Con la ricerca, premendo CTRL+f vengono si evidenziati gli ambi doppi, ma la colorazione dei numeri nel quadro estrazionale non è corrispondente, chiedevo, a chi ne sa più di me di VBA, se fosse possibile modificare la colorazione. Grazie.
Checco
 

Allegati

Checco

Utente junior
21 Aprile 2017
55
8
Torino
Excel 2016
0
Pubblica la macro che esegui con CTRL+f
Visual Basic:
Sub RicercaAmboVertibileBis()
Dim Num As Integer
Dim Estrazione  As Range
Dim Vertibile As Integer
Dim iRow_1 As Integer
Dim iCol_1 As Integer
Dim iRow_2 As Integer
Dim iCol_2 As Integer
Dim iCol_3 As Integer
Dim iCol_4 As Integer
Dim Ind As Byte
Dim Gemello As Boolean
Dim Testo As String
Dim Coll As New Collection


Set Estrazione = Range("b5:g15")
Estrazione.Interior.ColorIndex = xlNone
Ind = 2
On Error Resume Next
For iRow_1 = 1 To Estrazione.Rows.Count - 1
    For iCol_1 = 2 To Estrazione.Columns.Count
        Gemello = False
        Num = Estrazione(iRow_1, iCol_1)
        Vertibile = Mid(Format(Num, "00"), 2, 1) & Mid(Format(Num, "00"), 1, 1)
        If Mid(Format(Num, "00"), 2, 1) = Mid(Format(Num, "00"), 1, 1) Then
            Gemello = True
        End If
        For iRow_2 = iRow_1 + 1 To Estrazione.Rows.Count
            For iCol_2 = 2 To Estrazione.Columns.Count
                If Estrazione(iRow_2, iCol_2) = Vertibile And Vertibile <> Gemello Then
                    For iCol_3 = 2 To Estrazione.Columns.Count
                        For iCol_4 = 2 To Estrazione.Columns.Count
                            If iCol_1 <> iCol_3 Then
                                If iCol_2 <> iCol_4 Then
                                    If Estrazione(iRow_1, iCol_3) = Estrazione(iRow_2, iCol_4) Then 'And Gemello = False Then
                                        Ind = Ind + 1
                                        Estrazione(iRow_1, iCol_1).Interior.ColorIndex = Ind
                                        Estrazione(iRow_2, iCol_2).Interior.ColorIndex = Ind
                                        Estrazione(iRow_1, iCol_3).Interior.ColorIndex = Ind
                                        Estrazione(iRow_2, iCol_4).Interior.ColorIndex = Ind
                                        
                                        'Testo = Estrazione(iRow_1, 1) & ": " & Estrazione(iRow_1, iCol_1) & " - " & Estrazione(iRow_1, iCol_3) '& vbCrLf
                                        'Testo = Testo & " - " & Estrazione(iRow_2, 1) & ": " & Estrazione(iRow_2, iCol_2) & " - " & Estrazione(iRow_2, iCol_4)
                                        'Coll.Add Testo, Estrazione(iRow_1, iCol_1) & Estrazione(iRow_1, iCol_3) & Estrazione(iRow_2, iCol_2) & Estrazione(iRow_2, iCol_4)
                                        'Debug.Print Testo
                                    End If
                                End If
                            End If
                        Next iCol_4
                    Next iCol_3
                ElseIf Estrazione(iRow_1, iCol_1) = Estrazione(iRow_2, iCol_2) Then
                    For iCol_3 = iCol_1 To Estrazione.Columns.Count
                        For iCol_4 = 2 To Estrazione.Columns.Count
                            If Estrazione(iRow_1, iCol_3) = Estrazione(iRow_2, iCol_4) Then
                                If Estrazione(iRow_1, iCol_1) <> Estrazione(iRow_1, iCol_3) And Estrazione(iRow_2, iCol_2) <> Estrazione(iRow_2, iCol_4) Then
                                        
                                    Testo = Estrazione(iRow_1, 1) & ": " & Estrazione(iRow_1, iCol_1) & " - " & Estrazione(iRow_1, iCol_3) '& vbCrLf
                                    Testo = Testo & " - " & Estrazione(iRow_2, 1) & ": " & Estrazione(iRow_2, iCol_2) & " - " & Estrazione(iRow_2, iCol_4)
                                    Coll.Add Testo, Estrazione(iRow_1, iCol_1) & Estrazione(iRow_1, iCol_3) & Estrazione(iRow_2, iCol_2) & Estrazione(iRow_2, iCol_4)
                                    'Debug.Print Testo
                                End If
                            End If
                        Next
                    Next

                End If
            Next iCol_2
        Next iRow_2
    Next iCol_1
Next iRow_1
On Error GoTo 0

Testo = ""
For iRow_1 = 1 To Coll.Count
    Testo = Testo & Coll(iRow_1) & vbCrLf
Next
MsgBox Testo, vbInformation + vbOKOnly, "Doppio Ambo"

Set Estrazione = Nothing
Set Coll = Nothing

End Sub
 
Ultima modifica di un moderatore:

ges

Excel/VBA Expert
Amministratore
Expert
21 Giugno 2015
18.842
113
Como
2011MAC 2016WIN
353
Ciao,
come dice alfrimpa @alfrimpa cappello_saluta il codice va sempre pubblicato così da non costringere gli utenti a scaricare il file qualora non ce ne fosse bisogno.

Comunque ho visto la macro che c'è nel file e mi sembrata troppo ridondante e poco efficace.
Opterei per una più semplice
Visual Basic:
Sub RicercaAmboVertibileBis()
    Dim Rng As Range, Rng2 As Range, Cell As Range
    Dim Cell2 As Range, Colour As Integer
    Set Rng2 = ActiveSheet.Range("C5:G15")
    Rng2.Interior.ColorIndex = xlNone
    Colour = 3
    For Each Rng In Rng2.Columns
        For Each Cell In Rng.Cells
            If Application.CountIf(Rng, Cell.Value) > 1 And _
                Cell.Interior.ColorIndex = xlNone And Not IsEmpty(Cell.Value) Then
                For Each Cell2 In Rng.Cells
                    If Cell2.Value = Cell.Value Then Cell2.Interior.ColorIndex = Colour
                Next
                Colour = Colour + 1
                If Colour = 50 Then Colour = 3
            End If
        Next
    Next
End Sub
Ho lasciato che i colori si aggiungano con Alt+f ma ritengo superfluo se si prevede uno SpiButton che al cambiare richiama la macro.
Inoltre andrebbe considerata l'esigenza di bloccarlo quando arriva al limite mnimo o massimo
Visual Basic:
Private Sub SpinButton1_SpinDown()
    With Range("W1")
        If .Value = 1 Then
            MsgBox "Limite numerico minimo raggiunto", vbInformation, "NOTIFICA"
            Exit Sub
        End If
        Application.ScreenUpdating = False
        .Value = .Value - 1
    End With
    Range("C5:G15").Interior.ColorIndex = xlNone
    Call RicercaAmboVertibileBis
    Application.ScreenUpdating = True
End Sub

Private Sub SpinButton1_SpinUp()
    Dim ultimo As Integer
    With Sheets("Tabella Estrazioni")
        uR = .Cells(Rows.Count, 1).End(xlUp).Row
        ultimo = .Cells(uR, 1)
    End With
    With Range("W1")
        If .Value = ultimo Then
            MsgBox "Limite numerico massimo raggiunto", vbInformation, "NOTIFICA"
            Exit Sub
        End If
        Application.ScreenUpdating = False
        .Value = .Value + 1
    End With
    Range("C5:G15").Interior.ColorIndex = xlNone
    Call RicercaAmboVertibileBis
End Sub
Ti allego il file
 

Allegati

  • Like
Reactions: Checco

Checco

Utente junior
21 Aprile 2017
55
8
Torino
Excel 2016
0
Ciao,
come dice alfrimpa @alfrimpa cappello_saluta il codice va sempre pubblicato così da non costringere gli utenti a scaricare il file qualora non ce ne fosse bisogno.

Comunque ho visto la macro che c'è nel file e mi sembrata troppo ridondante e poco efficace.
Opterei per una più semplice
Visual Basic:
Sub RicercaAmboVertibileBis()
    Dim Rng As Range, Rng2 As Range, Cell As Range
    Dim Cell2 As Range, Colour As Integer
    Set Rng2 = ActiveSheet.Range("C5:G15")
    Rng2.Interior.ColorIndex = xlNone
    Colour = 3
    For Each Rng In Rng2.Columns
        For Each Cell In Rng.Cells
            If Application.CountIf(Rng, Cell.Value) > 1 And _
                Cell.Interior.ColorIndex = xlNone And Not IsEmpty(Cell.Value) Then
                For Each Cell2 In Rng.Cells
                    If Cell2.Value = Cell.Value Then Cell2.Interior.ColorIndex = Colour
                Next
                Colour = Colour + 1
                If Colour = 50 Then Colour = 3
            End If
        Next
    Next
End Sub
Ho lasciato che i colori si aggiungano con Alt+f ma ritengo superfluo se si prevede uno SpiButton che al cambiare richiama la macro.
Inoltre andrebbe considerata l'esigenza di bloccarlo quando arriva al limite mnimo o massimo
Visual Basic:
Private Sub SpinButton1_SpinDown()
    Application.ScreenUpdating = False
    Range("C5:G15").Interior.ColorIndex = xlNone
    With Range("W1")
        If .Value = 1 Then
            MsgBox "Limite numerico minimo raggiunto", vbInformation, "NOTIFICA"
            Exit Sub
        End If
        .Value = .Value - 1
    End With
    Call RicercaAmboVertibileBis
    Application.ScreenUpdating = True
End Sub


Private Sub SpinButton1_SpinUp()
    Dim ultimo As Integer
    Range("C5:G15").Interior.ColorIndex = xlNone
    With Sheets("Tabella Estrazioni")
        uR = .Cells(Rows.Count, 1).End(xlUp).Row
        ultimo = .Cells(uR, 1)
    End With
    With Range("W1")
        If .Value = ultimo Then
            MsgBox "Limite numerico massimo raggiunto", vbInformation, "NOTIFICA"
            Exit Sub
        End If
        .Value = .Value + 1
    End With
    Call RicercaAmboVertibileBis
    Application.ScreenUpdating = True
End Sub
Ti allego il file

Si, però a me interessa la ricerca di due ambi uguali nella stessa estrazione e che vengano evidenziati con colori. Grazie
 

ges

Excel/VBA Expert
Amministratore
Expert
21 Giugno 2015
18.842
113
Como
2011MAC 2016WIN
353
Allora ho capito una cosa diversa.
Ora per non ho tempo per rivedere la macro.
 

Rubik72

Excel/VBA Expert
Supermoderatore
Expert
12 Dicembre 2015
5.392
83
47
Cosenza
Excel 2016
165
Un saluto a tutti.
Prova con queste modifiche:
Codice:
Sub RicercaAmboVertibileBis()
Dim Estrazione  As Range
Dim iRow_1 As Integer
Dim iCol_1 As Integer
Dim iRow_2 As Integer
Dim iCol_2 As Integer
Dim iCol_3 As Integer
Dim iCol_4 As Integer
Dim Colore As Byte

Colore = 3

Set Estrazione = Range("b5:g15")
Estrazione.Interior.ColorIndex = xlNone
For iRow_1 = 1 To Estrazione.Rows.Count - 1
    For iCol_1 = 2 To Estrazione.Columns.Count
        For iRow_2 = iRow_1 + 1 To Estrazione.Rows.Count
            For iCol_2 = 2 To Estrazione.Columns.Count
                If Estrazione(iRow_1, iCol_1) = Estrazione(iRow_2, iCol_2) Then
                    For iCol_3 = iCol_1 To Estrazione.Columns.Count
                        For iCol_4 = 2 To Estrazione.Columns.Count
                            If Estrazione(iRow_1, iCol_3) = Estrazione(iRow_2, iCol_4) Then
                                If Estrazione(iRow_1, iCol_1) <> Estrazione(iRow_1, iCol_3) And Estrazione(iRow_2, iCol_2) <> Estrazione(iRow_2, iCol_4) Then
                                        
                                    Estrazione(iRow_1, iCol_1).Interior.ColorIndex = Colore
                                    Estrazione(iRow_1, iCol_3).Interior.ColorIndex = Colore
                                    Estrazione(iRow_2, iCol_2).Interior.ColorIndex = Colore
                                    Estrazione(iRow_2, iCol_4).Interior.ColorIndex = Colore
                                    Colore = Colore + 1
                                End If
                            End If
                        Next
                    Next
                End If
            Next iCol_2
        Next iRow_2
    Next iCol_1
Next iRow_1

Set Estrazione = Nothing
End Sub
 
  • Like
Reactions: ges

Checco

Utente junior
21 Aprile 2017
55
8
Torino
Excel 2016
0
Un saluto a tutti.
Prova con queste modifiche:
Codice:
Sub RicercaAmboVertibileBis()
Dim Estrazione  As Range
Dim iRow_1 As Integer
Dim iCol_1 As Integer
Dim iRow_2 As Integer
Dim iCol_2 As Integer
Dim iCol_3 As Integer
Dim iCol_4 As Integer
Dim Colore As Byte

Colore = 3

Set Estrazione = Range("b5:g15")
Estrazione.Interior.ColorIndex = xlNone
For iRow_1 = 1 To Estrazione.Rows.Count - 1
    For iCol_1 = 2 To Estrazione.Columns.Count
        For iRow_2 = iRow_1 + 1 To Estrazione.Rows.Count
            For iCol_2 = 2 To Estrazione.Columns.Count
                If Estrazione(iRow_1, iCol_1) = Estrazione(iRow_2, iCol_2) Then
                    For iCol_3 = iCol_1 To Estrazione.Columns.Count
                        For iCol_4 = 2 To Estrazione.Columns.Count
                            If Estrazione(iRow_1, iCol_3) = Estrazione(iRow_2, iCol_4) Then
                                If Estrazione(iRow_1, iCol_1) <> Estrazione(iRow_1, iCol_3) And Estrazione(iRow_2, iCol_2) <> Estrazione(iRow_2, iCol_4) Then
                                       
                                    Estrazione(iRow_1, iCol_1).Interior.ColorIndex = Colore
                                    Estrazione(iRow_1, iCol_3).Interior.ColorIndex = Colore
                                    Estrazione(iRow_2, iCol_2).Interior.ColorIndex = Colore
                                    Estrazione(iRow_2, iCol_4).Interior.ColorIndex = Colore
                                    Colore = Colore + 1
                                End If
                            End If
                        Next
                    Next
                End If
            Next iCol_2
        Next iRow_2
    Next iCol_1
Next iRow_1

Set Estrazione = Nothing
End Sub

Fantastico Rubik72 a primo controllo va benissimo, grazie mille :stringomano:
Checco
 

Checco

Utente junior
21 Aprile 2017
55
8
Torino
Excel 2016
0
Un saluto a tutti.
Prova con queste modifiche:
Codice:
Sub RicercaAmboVertibileBis()
Dim Estrazione  As Range
Dim iRow_1 As Integer
Dim iCol_1 As Integer
Dim iRow_2 As Integer
Dim iCol_2 As Integer
Dim iCol_3 As Integer
Dim iCol_4 As Integer
Dim Colore As Byte

Colore = 3

Set Estrazione = Range("b5:g15")
Estrazione.Interior.ColorIndex = xlNone
For iRow_1 = 1 To Estrazione.Rows.Count - 1
    For iCol_1 = 2 To Estrazione.Columns.Count
        For iRow_2 = iRow_1 + 1 To Estrazione.Rows.Count
            For iCol_2 = 2 To Estrazione.Columns.Count
                If Estrazione(iRow_1, iCol_1) = Estrazione(iRow_2, iCol_2) Then
                    For iCol_3 = iCol_1 To Estrazione.Columns.Count
                        For iCol_4 = 2 To Estrazione.Columns.Count
                            If Estrazione(iRow_1, iCol_3) = Estrazione(iRow_2, iCol_4) Then
                                If Estrazione(iRow_1, iCol_1) <> Estrazione(iRow_1, iCol_3) And Estrazione(iRow_2, iCol_2) <> Estrazione(iRow_2, iCol_4) Then
                                      
                                    Estrazione(iRow_1, iCol_1).Interior.ColorIndex = Colore
                                    Estrazione(iRow_1, iCol_3).Interior.ColorIndex = Colore
                                    Estrazione(iRow_2, iCol_2).Interior.ColorIndex = Colore
                                    Estrazione(iRow_2, iCol_4).Interior.ColorIndex = Colore
                                    Colore = Colore + 1
                                End If
                            End If
                        Next
                    Next
                End If
            Next iCol_2
        Next iRow_2
    Next iCol_1
Next iRow_1

Set Estrazione = Nothing
End Sub

Fantastico Rubik72 a primo controllo va benissimo, grazie mille :stringomano:
Checco
Buonasera Rubik72, mi sono entusiasmato troppo presto in quanto il listato mi da 1 solo risultato quando in realtà
con alcune estrazioni ci possono essere più di uno Ambi Doppi, chiedevo se fosse possibile rimediare a questa lacuna.
Grazie x la pazienza.
Checco
 

Checco

Utente junior
21 Aprile 2017
55
8
Torino
Excel 2016
0
Un saluto a tutti.
Prova con queste modifiche:
Codice:
Sub RicercaAmboVertibileBis()
Dim Estrazione  As Range
Dim iRow_1 As Integer
Dim iCol_1 As Integer
Dim iRow_2 As Integer
Dim iCol_2 As Integer
Dim iCol_3 As Integer
Dim iCol_4 As Integer
Dim Colore As Byte

Colore = 3

Set Estrazione = Range("b5:g15")
Estrazione.Interior.ColorIndex = xlNone
For iRow_1 = 1 To Estrazione.Rows.Count - 1
    For iCol_1 = 2 To Estrazione.Columns.Count
        For iRow_2 = iRow_1 + 1 To Estrazione.Rows.Count
            For iCol_2 = 2 To Estrazione.Columns.Count
                If Estrazione(iRow_1, iCol_1) = Estrazione(iRow_2, iCol_2) Then
                    For iCol_3 = iCol_1 To Estrazione.Columns.Count
                        For iCol_4 = 2 To Estrazione.Columns.Count
                            If Estrazione(iRow_1, iCol_3) = Estrazione(iRow_2, iCol_4) Then
                                If Estrazione(iRow_1, iCol_1) <> Estrazione(iRow_1, iCol_3) And Estrazione(iRow_2, iCol_2) <> Estrazione(iRow_2, iCol_4) Then
                                     
                                    Estrazione(iRow_1, iCol_1).Interior.ColorIndex = Colore
                                    Estrazione(iRow_1, iCol_3).Interior.ColorIndex = Colore
                                    Estrazione(iRow_2, iCol_2).Interior.ColorIndex = Colore
                                    Estrazione(iRow_2, iCol_4).Interior.ColorIndex = Colore
                                    Colore = Colore + 1
                                End If
                            End If
                        Next
                    Next
                End If
            Next iCol_2
        Next iRow_2
    Next iCol_1
Next iRow_1

Set Estrazione = Nothing
End Sub

Fantastico Rubik72 a primo controllo va benissimo, grazie mille :stringomano:
Checco
 

Sostieni ForumExcel

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