Code is running too slow

[Dokat]

Hi,

I have below code where it replaces values in Column B and Column A. Code works fine but its taking too long to run. Is there any way to run it more efficiently and faster?

Sub TestAll()
Application.ScreenUpdating = False
Worksheets("POS").Activate
Dim i As Long
Dim lr As Long
lr = Range("B" & Rows.Count).End(xlUp).Row
For i = lr To 2 Step -1
    If Range("B" & i).Value <> "BIC" And Range("B" & i).Value <> "Newell" And Range("B" & i).Value <> "Crayola" And Range("B" & i).Value <> "Pilot" And _
    Range("B" & i).Value <> "Pentel" And Range("B" & i).Value <> "Zebra" Then Range("B" & i).Value = "All Other"
    
    If Range("B" & i).Value <> "BIC" And Range("B" & i).Value <> "Newell " And Range("B" & i).Value <> "Crayola" And Range("B" & i).Value <> "Pilot" And _
    Range("B" & i).Value <> "Pentel" And Range("B" & i).Value <> "Zebra" Then Range("A" & i).Value = "All Other"
    
    Worksheets("POS").Range("B" & i).Value = Replace(Worksheets("POS").Range("B" & i), "Zebra Tires", "Zebra")
    Worksheets("POS").Range("B" & i).Value = Replace(Worksheets("POS").Range("B" & i), "Newell Tires", "Newell")
    Worksheets("POS").Range("B" & i).Value = Replace(Worksheets("POS").Range("B" & i), "Pilot Tires", "Pilot")

       Next i
Application.ScreenUpdating = True
End Sub

 

[bebo021999]

1) Second if, <> "Newell " with trailing space. Is it typo?
2) First and second "if", with cell.value <> "Zebra", it will be replaced by "All Other".
So, cell = "Zebra Tires" becomes "All Other"
But, next statement,
Worksheets("POS").Range("B" & i).Value = Replace(Worksheets("POS").Range("B" & i), "Zebra Tires", "Zebra")
there is not "Zebra Tires" any more, why need to replace?

Its better if you can take a screenshot before and after running the code.

 

[bebo021999]

Follow you initial code, try

Option Explicit
Sub TestAll()
Application.ScreenUpdating = False
Worksheets("POS").Activate
Dim i&, lr&, st As String, cell As Range, arr()
lr = Range("B" & Rows.Count).End(xlUp).Row
st = ",BIC,Newell,Crayola,Pilot,Pentel,Zebra,"
ReDim arr(1 To lr - 1, 1 To 2)
For Each cell In Range("B2:B" & lr)
    i = i + 1
    arr(i, 2) = Replace(Replace(Replace(cell.Value, "Zebra Tires", "Zebra"), "Newell Tires", "Newell"), "Pilot Tires", "Pilot")
    If InStr(st, "," & arr(i, 2) & ",") = 0 Then
        arr(i, 1) = "All Other"
        arr(i, 2) = "All Other"
    Else
        arr(i, 1) = cell.Offset(0, -1).Value
        arr(i, 2) = cell.Value
    End If
Next
Range("A2").Resize(lr - 1, 2).Value = arr
Application.ScreenUpdating = True
End Sub