Excel VBA - 循环行并在满足条件时复制粘贴到另一张纸

Question

我有 2 张纸 - “当前”和“电子邮件”。

1. 我想要一个脚本来逐行读取 A - D 列上的内容。
   
2. 如果 D 列 =“”，则复制相应的 B 列值并粘贴（并覆盖）到单元格 A1 中的“电子邮件”工作表。
   
3. 最后，对于步骤 2 中标识的行，在“当前”工作表 D 列中输入文本“电子邮件已发送”

Answer 1

请尝试下一个代码。它使用数组并且主要在内存中工作，即使要处理大范围，它也应该非常快。它可以预先清除“电子邮件”表中的 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

请在测试后发送一些反馈。