Sub Buscar_Numeros() 'Por.Dante Amor     Application.ScreenUpdating = False     Set h1 = Sheets("numeros")     Set h2 = Sheets("formato")     '     uc = h1.Cells(2, Columns.Count).End(xlToLeft).Column     For j = Columns("F").Column To uc Step 5         h2.Range("B2:E7").Copy         h1.Cells(2, j).PasteSpecial Paste:=xlPasteFormats     Next     '     cod = Format(h1.[A2], "0000")     For i = 1 To 4         Cells(3, i) = Mid(cod, i, 1)     Next     '     ns = Array(h1.[A3], h1.[B3], h1.[C3], h1.[D3])     Dim celdas As New Collection     For j = Columns("F").Column To uc Step 5         Set celdas = Nothing         m = 0         For k = LBound(ns) To UBound(ns)             Set b = h1.Range(h1.Cells(2, j + k), h1.Cells(7, j + k)). _                 Find(ns(k), lookat:=xlWhole)             If Not b Is Nothing Then                 m = m + 1                 celdas.Add b.Row & "," & j + k             Else                 Exit For             End If         Next         If m = 4 Then             For p = 1 To celdas.Count                 dire = Split(celdas(p), ",")                 fila = Val(dire(0))                 col = Val(dire(1))                 h1.Cells(fila, col).Interior.ColorIndex = 3             Next         End If     Next     Range("A2").Select     Application.ScreenUpdating = True End Sub