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

CodePudding user response：

Should be quicker than copy-paste:

Sub Tester()
    Dim rw As Long, f As String
    With ActiveSheet
        rw = .Cells(.Rows.Count, "B").End(xlUp).Row
        f = Replace("=IF(B2:B<rw>=""Orange"",B2:B<rw>,A2:A<rw>)", "<rw>", rw)
        .Range("A2:A" & rw).value = Application.Evaluate(f)
    End With
End Sub

About 0.2sec for 100k rows

CodePudding user response：

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