Máximos colaboradores

Private Sub CommandButton1_Click(): Application.ScreenUpdating = False With Hoja2 If .Range("A" & .Rows.Count).End(xlUp).Row > 1 Then .Range("A2:J" & .Range("A" & .Rows.Count).End(xlUp).Row).ClearContents End If End With With Hoja1 ufh1 = .Range("J" & .Rows.Count).End(xlUp).Row For Each buscado In .Range("A3:A" & ufh1) ufh2 = Hoja2.Range("A" & Hoja2.Rows.Count).End(xlUp).Row + 1 Select Case buscado.Value Case "cliente:" cliente = .Cells(buscado.Row, 2).Value proyecto = .Cells(buscado.Row, 4).Value orden = .Cells(buscado.Row, 8).Value empaque = .Cells(buscado.Row, 11).Value Case "LOTE" i = 0 Do Until .Cells(buscado.Row + i + 2, 1).Value = "TOTALES" And .Cells(buscado.Row + i + 2, 2).Value = "" Hoja2.Cells(ufh2 + i, 1).Value = cliente Hoja2.Cells(ufh2 + i, 2).Value = proyecto Hoja2.Cells(ufh2 + i, 3).Value = orden Hoja2.Cells(ufh2 + i, 9).Value = empaque Hoja2.Cells(ufh2 + i, 4).Value = .Cells(buscado.Row + 2 + i, 1).Value Hoja2.Cells(ufh2 + i, 5).Value = .Cells(buscado.Row + 2 + i, 2).Value Hoja2.Cells(ufh2 + i, 6).Value = .Cells(buscado.Row + 2 + i, 3).Value Hoja2.Cells(ufh2 + i, 7).Value = .Cells(buscado.Row + 2 + i, 5).Value Hoja2.Cells(ufh2 + i, 8).Value = .Cells(buscado.Row + 2 + i, 7).Value i = i + 1 Loop Case "Fecha Empaque" fecha = .Cells(buscado.Row, 10).Value i = 1 Do Until Hoja2.Cells(ufh2 - i, 10).Value <> "" Or ufh2 - i < 2 Hoja2.Cells(ufh2 - i, 10).Value = fecha i = i + 1 Loop End Select Next buscado End With End Sub informe empaque.xlsm

Hola buenas , me gustaría realizar en este libro la siguiente idea. Que al marcar manualmente dicha posición de un número de 4 cifras en color rojo se marque en la misma posición en los demás cuadros tanto en la hoja actual como en la hoja 2 y la hoja 3 y dicho número coloreado se escriba en la columna bn de la hoja actual como se muestra en el libro tablaresultados1.xlsm