Прокрутите строку и скопируйте вставку на другой лист, если условие выполнено

Пожалуйста, попробуйте следующий код. Он использует массивы и работает в основном в памяти, он должен быть очень быстрым даже для обработки больших диапазонов. Он может предварительно очистить столбец A:A из листа «Электронная почта» или его можно адаптировать для добавления обработанного массива, начиная с последнего существующего значения:

Sub moveBBValues()
  Dim wsC As Worksheet, wsE As Worksheet, lastR As Long, arr, arrFin, i As Long, k As Long
  
  Set wsC = worksheets("Current")
  Set wsE = worksheets("Email")
  
  lastR = wsC.Range("B" & wsC.rows.count).End(xlUp).row 'lastr row in B:B column of "Current" sheet
  
  arr = wsC.Range("B2:D" & lastR).Value2 'place the range in an array for faster processing
  
  ReDim arrFin(1 To UBound(arr), 1 To 1) 'ReDim the final array for a maximum of possible elements
  
  For i = 1 To UBound(arr)       'iterate between the arr elements:
    If arr(i, 3) = "" Then       'if values in D:D is empty:
        k = k + 1                'increment the final array row variable
        arrFin(k, 1) = arr(i, 1) 'place the value from B:B in the final array
        arr(i, 3) = "email sent" 'write the new status in D:D
    End If
  Next i
  
  If k = 0 Then Exit Sub 'no empty cells in D:D
  
  'drop the modified array back in "Current" stheet
  wsC.Range("B2").Resize(UBound(arr), UBound(arr, 2)).Value2 = arr
  
  'uncomment the next line if you need to previously clear A:A contents
  'wsE.Columns("A").ClearContents
  
  'Drop only the loaded elements of final array, at once:
  wsE.Range("A1").Resize(k, 1).Value2 = arrFin
End Sub

Пожалуйста, оставьте отзыв после тестирования.

Альтернатива ADO:

Sub Test()
    Dim adoCN As Object, RS As Object
    Dim myFile As String, strSQL As String
    
    Sheets("Email").Range("A2:A" & Rows.Count) = Empty
    myFile = ThisWorkbook.FullName
    
    Set adoCN = CreateObject("ADODB.Connection")
    Set RS = CreateObject("ADODB.Recordset")
    
    adoCN.Provider = "Microsoft.ACE.OLEDB.12.0"
    adoCN.Properties("Data Source") = myFile
    adoCN.Properties("Extended Properties") = "Excel 12.0 Macro; HDR=No;"
    adoCN.Open
    
    strSQL = "Select F2 From [Current$] Where F4 Is Null And F2 Is Not Null"
    RS.Open strSQL, adoCN
    
    Sheets("Email").Range("A2").CopyFromRecordset RS
        
    strSQL = "Update [Current$] Set F4='email sent' Where F4 Is Null And F2 Is Not Null"
    adoCN.Execute (strSQL)
    
    Set RS = Nothing
    Set adoCN = Nothing
End Sub

Копирование и замена значений

Функциональность (Логика)

• Он очищает существующие значения в столбце назначения.
• Если искомое значение пусто, а возвращаемое значение не является ошибкой или пустым, оно заменяет (пустое) искомое значение указанной строкой и копирует возвращаемое значение в следующую строку целевого столбца.
• При необходимости он удаляет повторяющиеся возвращаемые значения из столбца назначения.

Код

• Он очищает существующие значения в столбце назначения.
• Он копирует все исходные значения поиска (измененные или нет) в исходный диапазон поиска (возвращая любые (неожиданные) формулы в качестве значений).
• Он возвращает необходимые значения в столбце назначения.
• Он отображает окно сообщения.

Sub CopyISINsToEmail()
    
    Const PROC_TITLE As String = "Copy ISINs To Email"
     
    ' Define constants.

    ' Source
    Const SRC_SHEET_NAME As String = "Current"
    Const SRC_TOP_RETURN_CELL_ADDRESS As String = "B2"
    Const SRC_LOOKUP_COLUMN As String = "D"
    Const SRC_REPLACEMENT As String = "email sent"
    ' Destination
    Const DST_SHEET_NAME As String = "Email"
    Const DST_TOP_CELL_ADDRESS As String = "A1"
    ' Other
    Const REMOVE_DUPLICATE_RETURN_VALUES As Boolean = False
    
    ' Reference the workbook.
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    
    ' Reference the destination objects and clear existing data.
    
    Dim dws As Worksheet: Set dws = wb.Sheets(DST_SHEET_NAME)
    Dim dcell As Range: Set dcell = dws.Range(DST_TOP_CELL_ADDRESS)
    dcell.Resize(dws.Rows.Count - dcell.Row + 1).ClearContents
    
    ' Reference the source objects.
    
    Dim sws As Worksheet: Set sws = wb.Sheets(SRC_SHEET_NAME)
    
    Dim slrg As Range, srrg As Range, SourceRowsCount As Long
    
    With sws.Range(SRC_TOP_RETURN_CELL_ADDRESS)
        SourceRowsCount = sws.Cells(sws.Rows.Count, .Column) _
            .End(xlUp).Row - .Row + 1
        If SourceRowsCount < 1 Then
            MsgBox "No data found" & vbLf & "in ""'" & sws.Name & "'!" _
                & .Resize(sws.Rows.Count - .Row + 1).Address(0, 0) & """!", _
                vbExclamation, PROC_TITLE
            Exit Sub
        End If
        Set srrg = .Resize(SourceRowsCount)
        Set slrg = srrg.EntireRow.Columns(SRC_LOOKUP_COLUMN)
    End With
        
    ' Return the values of the source ranges in arrays.
        
    Dim lData() As Variant, rData() As Variant
    
    If SourceRowsCount = 1 Then
        ReDim lData(1 To 1, 1 To 1): lData(1, 1) = slrg.Value
        ReDim rData(1 To 1, 1 To 1): rData(1, 1) = srrg.Value
    Else
        lData = slrg.Value
        rData = srrg.Value
    End If
    
    ' For each row in the source arrays:
    '  - Check if the lookup value is blank.
    '  - Check if the return value is no error or blank.
    '  - When both conditions are met:
    '     - Write the replacement string to the lookup array.
    '     - Once the number of replacements becomes smaller than the source row,
    '       write the return value to the top (of the return array).
    
    Dim rValue As Variant, lValue As Variant
    Dim sr As Long, ReplacementsCount As Long
    Dim WereConditionsMet As Boolean
    Dim AreValuesValid As Boolean, AreRowsDifferent As Boolean
    
    For sr = 1 To SourceRowsCount
        ' Check if conditions are met.
        lValue = lData(sr, 1)
        If Len(CStr(lValue)) = 0 Then ' is blank
            rValue = rData(sr, 1)
            If Not IsError(rValue) Then ' is no error
                If Len(rValue) > 0 Then ' is not blank
                    WereConditionsMet = True ' never reset
                    AreValuesValid = True ' reset later
                End If
            End If
        End If
        ' Write if conditions are met.
        If AreValuesValid Then
            lData(sr, 1) = SRC_REPLACEMENT
            ReplacementsCount = ReplacementsCount + 1
            If Not AreRowsDifferent Then
                If ReplacementsCount < sr Then
                    AreRowsDifferent = True ' never reset
                End If
            End If
            If AreRowsDifferent Then ' i.e. 'If ReplacementsCount < sr Then'
                rData(ReplacementsCount, 1) = rData(sr, 1) ' write to top
            End If
            AreValuesValid = False ' reset
        End If
    Next sr
    
    ' Check if no conditions were met.
    
    If Not WereConditionsMet Then ' i.e. 'If ReplacementsCount = 0 Then'
        MsgBox "No value pairs meeting the required conditions were found" _
            & vbLf & "in ""'" & sws.Name & "'!" _
            & Union(slrg, srrg).Address(0, 0) & """!", _
            vbExclamation, PROC_TITLE
        Exit Sub
    End If
    
    ' Store the number of replacements in a new variable.
    
    Dim ReturnValuesCount As Long: ReturnValuesCount = ReplacementsCount
    ' Note that the number of replacements may be greater than
    ' the number of return values after removing duplicate return values.
    
    ' Optionally, remove duplicates from the top of the return array.
    
    If REMOVE_DUPLICATE_RETURN_VALUES Then
        ' Reset already used variables.
        AreRowsDifferent = False
        ReturnValuesCount = 0
        
        Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
        dict.CompareMode = vbTextCompare
        
        Dim rString As String
        
        For sr = 1 To ReplacementsCount
            rString = CStr(rData(sr, 1))
            If Not dict.Exists(rString) Then
                ReturnValuesCount = ReturnValuesCount + 1
                dict(rString) = Empty
                If Not AreRowsDifferent Then
                    If ReturnValuesCount < sr Then
                        AreRowsDifferent = True ' never reset
                    End If
                End If
                If AreRowsDifferent Then
                    rData(ReturnValuesCount, 1) = rData(sr, 1) ' write to top
                End If
            End If
        Next sr
        
    End If
    
    ' Write the values from the arrays to the ranges.
    
    ' Write the values from the lookup array
    ' to the source lookup range.
    slrg.Value = lData
    ' Write the values from (the top of) the return array
    ' to the destination range.
    Dim drg As Range: Set drg = dcell.Resize(ReturnValuesCount)
    drg.Value = rData
    
    ' Inform.

    Dim Msg As String:
    Msg = "Copied " & ReturnValuesCount _
        & IIf(REMOVE_DUPLICATE_RETURN_VALUES, " distinct ", "") _
        & " value" & IIf(ReturnValuesCount = 1, "", "s") _
        & vbLf & "from ""'" & sws.Name & "'!" & srrg.Address(0, 0) & """" _
        & vbLf & "to ""'" & dws.Name & "'!" & drg.Address(0, 0) & """." _
        & vbLf & vbLf _
        & IIf(ReturnValuesCount = ReplacementsCount, "The corresponding", _
            ReplacementsCount) _
        & " blank cell" & IIf(ReplacementsCount = 1, "", "s") _
        & vbLf & "in ""'" & sws.Name & "'!" & slrg.Address(0, 0) & """" _
        & vbLf & "were populated with """ & SRC_REPLACEMENT & """."

    MsgBox Msg, vbInformation, PROC_TITLE
    
End Sub