Inefficient code taking too long to run

[Dokat]

Hi,

I have a worksheet ("POS") where I want to change column A values to "All Other" if Column B values are not "BIC", "Newell Brands", "Crayola", Pilot Pen, "Pentel", "Private Label" and "Zebra Pen Corporation" starting row 2. Below code works however taking forever to run. Appreciate any help to simplify the code to run more efficiently and fast. Thanks

Sub ReplaceAllOther()

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 Brands" And Range("B" & i).Value <> "Crayola" And Range("B" & i).Value <> "Private Label" And Range("B" & i).Value <> "Pilot Pen" And _
    Range("B" & i).Value <> "Pentel" And Range("B" & i).Value <> "Zebra Pen Corporation" Then Range("B" & i).Value = "All Other"
    
    If Range("B" & i).Value <> "BIC" And Range("B" & i).Value <> "Newell Brands" And Range("B" & i).Value <> "Crayola" And Range("B" & i).Value <> "Private Label" And Range("B" & i).Value <> "Pilot Pen" And _
    Range("B" & i).Value <> "Pentel" And Range("B" & i).Value <> "Zebra Pen Corporation" Then Range("A" & i).Value = "All Other"
       Next i
Application.ScreenUpdating = True

End Sub

 

[My Aswer Is This]

Not sure what slow means to you.
Try this:

Sub Hello()
'Modified  2/27/2022  9:31:47 PM  EST
Application.ScreenUpdating = False
Worksheets("POS").Activate
Dim i As Long
Dim lr As Long
lr = Range("B" & Rows.Count).End(xlUp).Row

For i = 2 To lr
    
    Select Case Cells(i, 2).Value
        Case "BIC", "Newell Brands", "Crayola", "Pilot Pen", "Pentel", "Private Label", "Zebra Pen Corporation"
        
        Case Else
            Cells(i, 2).Value = "All Other"
        End Select
        Next
Application.ScreenUpdating = True
End Sub

 

[Dokat]

Not sure what slow means to you.
Try this:

Sub Hello()
'Modified  2/27/2022  9:31:47 PM  EST
Application.ScreenUpdating = False
Worksheets("POS").Activate
Dim i As Long
Dim lr As Long
lr = Range("B" & Rows.Count).End(xlUp).Row

For i = 2 To lr
   
    Select Case Cells(i, 2).Value
        Case "BIC", "Newell Brands", "Crayola", "Pilot Pen", "Pentel", "Private Label", "Zebra Pen Corporation"
       
        Case Else
            Cells(i, 2).Value = "All Other"
        End Select
        Next
Application.ScreenUpdating = True
End Sub

Hi this code run fast however didn't work correctly. What i'd like to do is the change

Not sure what slow means to you.
Try this:

Sub Hello()
'Modified  2/27/2022  9:31:47 PM  EST
Application.ScreenUpdating = False
Worksheets("POS").Activate
Dim i As Long
Dim lr As Long
lr = Range("B" & Rows.Count).End(xlUp).Row

For i = 2 To lr
   
    Select Case Cells(i, 2).Value
        Case "BIC", "Newell Brands", "Crayola", "Pilot Pen", "Pentel", "Private Label", "Zebra Pen Corporation"
       
        Case Else
            Cells(i, 2).Value = "All Other"
        End Select
        Next
Application.ScreenUpdating = True
End Sub

Thank you. Previous code took 6 mins to run compared to this ne only 25 secs.

I modified the range slightly, it works seamlessly

Sub ReplaceAllOther()

Application.ScreenUpdating = False
Worksheets("POS").Activate
Dim i As Long
Dim lr As Long
lr = Range("B" & Rows.Count).End(xlUp).Row

For i = 2 To lr
    
    Select Case Cells(i, 2).Value
        Case "BIC", "Newell Brands", "Crayola", "Pilot Pen", "Pentel", "Private Label", "Zebra Pen Corporation"
        
        Case Else
            Cells(i, 1).Value = "All Other"
        End Select
        Next
Application.ScreenUpdating = True
End Sub

 

[My Aswer Is This]

Glad I was able to help you.
Come back here to Mr. Excel next time you need additional assistance.

Your original code showed column B
Your modified code shows Column A and B

 

[jolivanes]

You have been serviced but here is another one. (going by your "modified" code)
In memory only. Should be fastest of all

Sub Another_Possibility()
Dim pens, i As Long
    With Worksheets("Sheet1")
    pens = .Range("A2:B" & .Cells(.Rows.Count, 2).End(xlUp).Row).Value
        For i = 2 To UBound(pens)
            Select Case pens(i, 2)
                Case "BIC", "Newell Brands", "Crayola", "Pilot Pen", "Pentel", "Private Label", "Zebra Pen Corporation"
                    Case Else
                pens(i, 1) = "All Other"
            End Select
        Next i
    End With
Cells(2, 1).Resize(UBound(pens), 2).Value = pens
End Sub

 

[Dokat]

You have been serviced but here is another one. (going by your "modified" code)
In memory only. Should be fastest of all

Sub Another_Possibility()
Dim pens, i As Long
    With Worksheets("Sheet1")
    pens = .Range("A2:B" & .Cells(.Rows.Count, 2).End(xlUp).Row).Value
        For i = 2 To UBound(pens)
            Select Case pens(i, 2)
                Case "BIC", "Newell Brands", "Crayola", "Pilot Pen", "Pentel", "Private Label", "Zebra Pen Corporation"
                    Case Else
                pens(i, 1) = "All Other"
            End Select
        Next i
    End With
Cells(2, 1).Resize(UBound(pens), 2).Value = pens
End Sub

Thank you