excel - 如何根据多个电子邮件地址复制行？

Question

我有一个庞大的数据列表，第 3 列包含电子邮件地址。

我正在尝试根据邮件列表复制行。只要该行包含邮件列表中的一个电子邮件地址，就应该将其复制到新工作表中。

我有代码可以一次根据一封电子邮件复制数据。

我为多个电子邮件地址设置了一个用户表单，但这效率不高。

这是我的代码，一次使用一个电子邮件地址。

Private Sub CommandButton1_Click()

    a = Worksheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    
    For i = 2 To a
    
        If Worksheets("Sheet1").Cells(i, 3).Value = "<@gmail.com>" Then
        
            Worksheets("Sheet1").Rows(i).Copy
            Worksheets("Sheet2").Activate

            b = Worksheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Row                
            
            Worksheets("Sheet2").Cells(b + 1, 1).Select        
            ActiveSheet.Paste                
            
            Worksheets("Sheet2").Activate
    
        End If
    Next
    
    Application.CutCopyMode = False
    
End Sub

如何根据多个电子邮件地址复制行？

标签： excelvba

Answer 1

我建议使用Advanced Filter 目标范围将在一个步骤中编写。如果您可以最大程度地减少代码从工作表读取/写入/写入的次数，它将运行得越快。

表 1

阅读代码中的注释，因为它们对于将其修改为您的真实数据非常重要。

特别是，如果您的第 3 列列表的格式与您在代码中显示的格式不同，您将需要修改 Criteria 范围以解决此问题。高级过滤器还可以接受条件中的通配符，因此如果您的第 3 列包含实际的电子邮件地址，这可能是另一种可能的方法。

Option Explicit
Sub copyWithEmail()
    Dim wsSrc As Worksheet, wsDest As Worksheet
    Dim rSrc As Range, rDest As Range, rCrit As Range
    Dim arrCrit As Variant
    Dim I As Long

Set wsSrc = Worksheets("sheet1")
Set wsDest = Worksheets("sheet2")

With wsDest
    .Cells.Clear 'optional
    Set rCrit = .Cells(1, 250) 'someplace off the screen view
    Set rDest = .Cells(1, 1)
End With

'assumes original data starts in A1
'assumes first row is a header row
Set rSrc = wsSrc.Cells(1, 1).CurrentRegion

'can get list of desired emails from user form; range someplace in the workbook; or hard-coded as we have here
arrCrit = Array("gmail.com", "abc.com")
    For I = 0 To UBound(arrCrit)

        'creating formula that mimics what you show in your code above.
        arrCrit(I) = "=" & """=<@" & arrCrit(I) & ">"""
    Next I

'create criteria range
'header is same header as in Source Data column 3
Set rCrit = rCrit.Resize(2 + UBound(arrCrit))
    rCrit(1) = rSrc(1, 3)
    rCrit.Offset(1).Resize(rCrit.Rows.Count - 1) = WorksheetFunction.Transpose(arrCrit)

'Activate wsDest since we will be copying here
wsDest.Activate

rSrc.AdvancedFilter Action:=xlFilterCopy, _
        CriteriaRange:=rCrit, CopyToRange:=rDest, Unique:=False
rDest.CurrentRegion.EntireColumn.AutoFit
rCrit.Clear 'get rid of this range
End Sub

表 2