In Excel what is the most efficient way to find and copy/paste noncontiguous data in columns?

I have some code that works okay on a small data set, however, I'm looking for the most efficient way to handle this over in 100k+ rows.

The data is in two columns. In column B, wherever "Orange" is listed, I would like to copy/paste "Orange" into column A and replace "Citrus" for that row.

Here is my current code. I think it has some unnecessary bits in it now since I was trying to find a way to copy and paste all of the found cells at once.

SearchStr = "Orange"
Set SearchRng = Range("b2:b11)

With SearchRng
    Set FoundCell = .Find(SearchStr, LookIn:=xlValues, LookAt:=xlPart)
    If Not FoundCell Is Nothing Then
        FirstAdd = FoundCell.Address
        Do
            If Not AllFoundCells Is Nothing Then
                    Set AllFoundCells = Union(AllFoundCells, FoundCell)
                Else
                    Set AllFoundCells = FoundCell
            End If
            FoundCell.Copy Destination:=FoundCell.Offset(0, -1)
            Set FoundCell = .FindNext(FoundCell)
        Loop While FoundCell.Address <> FirstAdd
    End If
End With

Solution 1:

Replace If Match in Column

• If a string (sString) is found in a column (sCol), then write another string (dString (in this case dString = sString)) to another column (dCol).
• On my sample data of 1M rows (>200k of matches), it took less than 2s for the 'AutoFilter' solution and it took about 4s for the 'Array Loop' solution (3s for writing back to the range: drg.Value = dData).

Option Explicit

Sub UsingAutoFilter()
    
    ' Source
    Const sCol As String = "B"
    Const sString As String = "Orange"
    ' Destination
    Const dCol As String = "A"
    Const dString As String = "Orange"
    ' Both
    Const hRow As Long = 1 ' Header Row
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    If ws.AutoFilterMode Then ws.AutoFilterMode = False
    
    Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, sCol).End(xlUp).Row
    If lRow < hRow + 1 Then Exit Sub ' no data or just headers
    
    Dim rCount As Long: rCount = lRow - hRow + 1
    
    Dim srg As Range: Set srg = ws.Cells(hRow, sCol).Resize(rCount)
    Dim sdrg As Range: Set sdrg = srg.Resize(srg.Rows.Count - 1).Offset(1)
    
    srg.AutoFilter 1, sString
    
    Dim sdvrg As Range
    On Error Resume Next
        Set sdvrg = sdrg.SpecialCells(xlCellTypeVisible)
    On Error GoTo 0
    ws.AutoFilterMode = False
    
    If sdvrg Is Nothing Then Exit Sub ' no match found
    
    Dim ddvrg As Range
    Set ddvrg = sdvrg.Offset(, ws.Columns(dCol).Column - srg.Column)
    ddvrg.Value = dString

End Sub

Sub UsingArrayLoop()
    
    ' Source
    Const sCol As String = "B"
    Const sString As String = "Orange"
    ' Destination
    Const dCol As String = "A"
    Const dString As String = "Orange"
    ' Both
    Const fRow As Long = 2 ' First Data Row
    
    Dim ws As Worksheet: Set ws = ActiveSheet ' improve!
    
    Dim lRow As Long: lRow = ws.Cells(ws.Rows.Count, sCol).End(xlUp).Row
    If lRow < fRow Then Exit Sub ' no data
    
    Dim rCount As Long: rCount = lRow - fRow + 1
    
    Dim srg As Range: Set srg = ws.Cells(fRow, sCol).Resize(rCount)
    Dim drg As Range: Set drg = srg.EntireRow.Columns(dCol)
    
    Dim sData As Variant
    Dim dData As Variant
    
    If rCount = 1 Then
        ReDim sData(1 To 1, 1 To 1): sData(1, 1) = srg.Value
        ReDim dData(1 To 1, 1 To 1): dData(1, 1) = drg.Value
    Else
        sData = srg.Value
        dData = drg.Value
    End If
    
    Dim r As Long
    
    For r = 1 To rCount
        If StrComp(CStr(sData(r, 1)), sString, vbTextCompare) = 0 Then
            dData(r, 1) = dString
        End If
    Next r
    Erase sData
       
    drg.Value = dData

End Sub