在Excel中，查找和復制/粘貼列中不連續資料的最有效方法是什么？

我有一些在小型資料集上運行良好的代碼，但是，我正在尋找最有效的方法來處理超過 100k 行。

資料分為兩列。在 B 列中，無論在哪里列出“橙色”，我想將“橙色”復制/粘貼到 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

uj5u.com熱心網友回復：

如果在列中匹配則替換

• 如果sString在列 ( ) 中找到字串 ( sCol)，則將另一個字串 ( dString( 在本例中dString = sString)) 寫入另一列 ( dCol)。
• 在我的 1M 行（>200k 匹配項）的樣本資料中，“自動篩選”解決方案花費了不到 2 秒的時間，而“陣列回圈”解決方案花費了大約 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

uj5u.com熱心網友回復：

應該比復制粘貼更快：

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

100k 行大約 0.2 秒

Evaluate()ActiveSheet接受一個作業表函式并在（如果您使用Application.Evaluate表單）或特定作業表（如果您使用表單）的背景關系中對其進行評估the WorkSheet.Evaluate。它處理陣列公式（不需要添加{}），并且可以回傳一個陣列作為結果（這里我們只是直接分配給 ColA 范圍）

標籤：

上一篇：如何計算句子中的確切單詞？

下一篇：多個條件（字串陣列）的自動篩選未正確回傳