Excel 如何基于多个电子邮件地址复制行？
我有一个巨大的数据列表，第3列包含电子邮件地址Excel 如何基于多个电子邮件地址复制行？,excel,vba,Excel,Vba,我有一个巨大的数据列表，第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 wsDes
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
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
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
Private子命令按钮1\u单击（）
a=工作表（“Sheet1”）。单元格（Rows.Count，1）。结束（xlUp）。行
对于i=2到a
如果工作表（“表1”）.单元格（i，3）.Value=”“，则
工作表（“表1”）.行（i）.副本
工作表（“表2”）。激活
b=工作表（“Sheet2”）.单元格（Rows.Count，1）.结束（xlUp）.行
工作表（“表2”）。单元格（b+1，1）。选择
活动表。粘贴
工作表（“表2”）。激活
如果结束
下一个
Application.CutCopyMode=False
端接头
如何根据多个电子邮件地址复制行？可能类似于将mialList的Sheet3
Private Sub CommandButton1_Click()
Dim Sh1 As Worksheet, Sh2 As Worksheet, Sh3 As Worksheet, fnd As Range, cl As Range
Set Sh1 = Worksheets("Sheet1")
Set Sh2 = Worksheets("Sheet2")
Set Sh3 = Worksheets("Sheet3")
Dim mailList As Range
x = Sh3.Range("A" & Sh3.Rows.Count).End(xlUp).Row
Set mailList = Sh3.Range("A2:A" & x)
'Assuming headers in row 1
For Each cl In mailList
b = Sh2.Range("A" & Sh2.Rows.Count).End(xlUp).Row + 1
Set fnd = Sh1.Columns(3).Find(cl)
If Not fnd Is Nothing Then
Sh2.Rows(b).Value = Sh1.Rows(fnd.Row).Value
End If
Next
End Sub
我建议使用
Advanced FilterOption 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
选项显式
Sub copyWithEmail（）
将wsSrc标注为工作表，将wsDest标注为工作表
变暗rSrc作为范围、rDest作为范围、rCrit作为范围
Dim-arrCrit作为变体
我想我会坚持多久
设置wsSrc=工作表（“表1”）
设置wsDest=工作表（“表2”）
用wsDest
.Cells.Clear“可选
将rCrit=.Cells（1250）设置为屏幕外的某个位置
设置rDest=.Cells（1，1）
以
'假定原始数据以A1开头
'假定第一行是标题行
设置rSrc=wsSrc.Cells（1,1）.CurrentRegion
'可以从用户表单中获取所需电子邮件的列表；在工作手册中的某个地方范围；或者像我们这里这样硬编码
arrCrit=Array（“gmail.com”、“abc.com”）
对于I=0到UBound（arrCrit）
'创建模仿您在上面代码中显示的公式。
ARRCLIT（I）=“=”和“=”
接下来我
'创建条件范围
'标题与源数据第3列中的标题相同
设置rCrit=rCrit.调整大小（2+UBound（arrCrit））
rCrit（1）=rSrc（1,3）
rCrit.Offset（1）.Resize（rCrit.Rows.Count-1）=工作表函数.Transpose（arrCrit）
'激活wsDest，因为我们将在此处复制
wsDest.Activate
rSrc.AdvancedFilter操作：=xlFilterCopy_
CriteriaRange:=rCrit，CopyToRange:=rDest，Unique:=False
rDest.CurrentRegion.entireclumn.AutoFit
rCrit.Clear“清除此范围”
端接头
不太清楚。您是否需要复制C列中包含电子邮件的所有单元格？或者我误解了您的意思。。？给出工作表的快照。您可以用类似
工作表（“Sheet2”）.单元格（i，3）的内容替换副本、激活、选择和粘贴代码。Value=工作表（“Sheet1”）.单元格（j，3）。Value