Excel 在列中查找和 copy/paste 非连续数据的最有效方法是什么？

Question

我有一些代码可以在小型数据集上正常工作，但是，我正在寻找最有效的方法来处理超过 10 万行的数据。

数据分为两列。在 B 列中，只要列出“橙色”，我想 copy/paste“橙色”进入 A 列并替换该行的“柑橘”。

这是我当前的代码。我认为它现在有一些不必要的部分，因为我试图找到一种方法来一次复制和粘贴所有找到的单元格。

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

Answer 1

应该比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 = .Evaluate(f) 'edited to remove `Application`
    End With
End Sub

10 万行大约 0.2 秒

Evaluate() 采用工作表函数并在 ActiveSheet（如果您使用 Application.Evaluate 形式）或特定工作表（如果您使用 the WorkSheet.Evaluate表格）。它处理数组公式（不需要添加 {}），并且可以 return 一个数组作为结果（这里我们直接分配给 ColA 范围）

Answer 2

如果列中匹配则替换

如果在列(sCol)中找到一个字符串(sString)，则写入另一个字符串(dString(在本例中为dString = sString))另一列 (dCol).
在我的 1M 行样本数据（>200k 匹配）中，'AutoFilter' 解决方案花费了不到 2 秒，'Array Loop' 解决方案花费了大约 4 秒（写回 3 秒到范围：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

Excel 在列中查找和 copy/paste 非连续数据的最有效方法是什么？

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

excel

search

vba

autofilter

如果列中匹配则替换