colorare numeri

Sub trova_e_colora()
Dim cerca As Range, trova As Range
Dim cercato As Range, trovato As Object
Dim sh As Worksheet, ur As Long, r As Long

Set sh = Sheets("Archivio")


With sh
    Set cerca = .Range("ab1:ai1")
    ur = .Cells(Rows.Count, "bf").End(xlUp).Row
    Set trova = .Range("d3:bf" & ur)
    
    For Each cercato In cerca
       Set trovato = trova.Find(cercato.Value, LookIn:=xlValues, lookat:=xlWhole)
            
            If Not trovato Is Nothing Then
                 r = trovato.Row
                
                    
                    trovato.Font.ColorIndex = 3
                    trovato.Font.Bold = True
                    trovato.Interior.Color = vbYellow
                    
                    Do
                        Set trovato = trova.FindNext(trovato)
                        trovato.Font.ColorIndex = 3
                        trovato.Font.Bold = True
                        trovato.Interior.Color = vbYellow
                       
                    Loop While Not trovato Is Nothing And r <> trovato.Row
                    
             
            End If
    Next cercato
        

End With

Set sh = Nothing
Set cerca = Nothing
Set trova = Nothing
Set trovato = Nothing


End Sub

Sub trova_e_colora()
Dim cerca As Range, trova As Range
Dim cercato As Range, trovato As Object
Dim sh As Worksheet, ur As Long, r As Long


Dim c As Long   ' variabile aggiunta


Set sh = Sheets("Archivio")


With sh
    Set cerca = .Range("ab1:ai1")
    ur = .Cells(Rows.Count, "bf").End(xlUp).Row
    Set trova = .Range("d3:bf" & ur)
    
    For Each cercato In cerca
       Set trovato = trova.Find(cercato.Value, LookIn:=xlValues, lookat:=xlWhole)
            
            If Not trovato Is Nothing Then
                 r = trovato.Row
                 c = trovato.Column  ' riga aggiunta
                
                    
                    trovato.Font.ColorIndex = 3
                    trovato.Font.Bold = True
                    trovato.Interior.Color = vbYellow
                    
                    Do
                        Set trovato = trova.FindNext(trovato)
                        trovato.Font.ColorIndex = 3
                        trovato.Font.Bold = True
                        trovato.Interior.Color = vbYellow
                        
            '=============================================================
            '  ***riga modificata***
            
            'ho modificato la riga seguente in quanto se presente lo stesso numero sulla stessa riga,
            'non prosegue sulle righe successive
            
                    Loop While Not trovato Is Nothing _
                        And r <> trovato.Row _
                        Or c <> trovato.Column
            '=============================================================
             
            End If
    Next cercato
        

End With

Set sh = Nothing
Set cerca = Nothing
Set trova = Nothing
Set trovato = Nothing


End Sub

Sub prova()
Dim ur As Long
Dim rng As Range
Dim rng2 As Range
Dim cel As Range
Dim cel2 As Range
ur = Cells(Rows.Count, 1).End(xlUp).Row
Set rng = Range("ab1:ai1")
Set rng2 = Range("D3:BF" & ur)
For Each cel In rng
    For Each cel2 In rng2
        If cel.Value = cel2.Value Then
            cel2.Interior.ColorIndex = 6
            cel2.Font.ColorIndex = 3
            cel2.Font.Bold = True
        End If
    Next cel2
Next cel
End Sub

Sub Colora()
Dim r, c, d, x, y, t, tt, Tbl1, Tbl2

t = Now
Tbl1 = Range("AB1:AI1")
r = Cells(Rows.Count, 1).End(xlUp).Row
Set Tbl2 = Range("D3:BF" & r)
With Tbl2
  .Interior.Color = RGB(255, 255, 255)
  .Font.Color = RGB(0, 0, 0)
  .Font.Bold = False
End With
For x = 1 To UBound(Tbl1, 2)
  If Tbl1(1, x) = "" Then GoTo 1
  d = Tbl1(1, x)
  For Each y In Tbl2
    If d = y Then
      With y
        .Interior.Color = RGB(255, 255, 0)
        .Font.Bold = True
        .Font.Color = RGB(255, 0, 0)
      End With
    End If
  Next y
1 Next x
tt = Now - t
MsgBox "Operazione Terminata" & Chr(13) & Chr(13) & "Tempo Impiegato" & Chr(13) & Chr(13) & _
    Format(tt, "hh:mm:ss"), vbInformation, "Ricerca Numeri"
End Sub

Sub Pulisce()
Dim r, Tbl2

r = Cells(Rows.Count, 1).End(xlUp).Row
Set Tbl2 = Range("D3:BF" & r)
With Tbl2
  .Interior.Color = RGB(255, 255, 255)
  .Font.Color = RGB(0, 0, 0)
  .Font.Bold = False
End With
End Sub