Sub trpr()
    Dim i As Range, f As Long, RowMax As Long

    With ThisWorkbook.Worksheets("Лист1").UsedRange
        RowMax = .Rows.Count + .Row -  1 
    End With

    Dim rng As Range
    Set rng = ThisWorkbook.Worksheets("Лист1").Range("B4:B" & CStr(RowMax))
    
    For Each i In rng
        f = xlNone
        Select Case i.Value
               Case  1 :  f =  3 
               Case  2 :  f =  6 
               Case  3 :  f =  38 
               Case  3 :  f =  40 
        End Select
        i.Offset(, - 1 ).Interior.ColorIndex = f
    Next

    Set rng = Nothing
    
End Sub