excel - 通过电子邮件搜索将 Excel 2003 中的数据行复制并粘贴到不同的工作表

Question

在任何人说什么之前，我已经浏览了几个与这个类似想法相关的帖子（通过不同的搜索条件然后修改它），但我无法让宏工作。这可能是由于我缺乏编程知识！我要做的就是在WORKSHEET 1中搜索一个电子邮件地址，如果找到它，将整行复制到WORKSHEET 2中的下一个空闲行。我正在使用 Excel 2003（是的，我是一个老顽固！）。

Answer 1

其实我觉得你是个聪明人；我个人讨厌 2007/2010 的用户界面有很多原因。

要回答你的问题，看看这是否有意义。（它又快又脏，所以它不是防弹的。不过，它应该给你一个起点。）

Sub FindAndCopyEmailAddress()


Dim vnt_Input As Variant
Dim rng_Found As Excel.Range
Dim wks1 As Excel.Worksheet, wks2 As Excel.Worksheet
Dim rng_target As Excel.Range
Dim l_FreeRow As Long

'Check that the sheets are there, and get a reference to
'them. Change the sheet names if they're different in yours.
On Error Resume Next
Set wks1 = ThisWorkbook.Worksheets("Sheet1")
Set wks2 = ThisWorkbook.Worksheets("Sheet2")

'If a runtime error occurs, jump to the line marked 
'ErrorHandler to display the details before exiting the 
'procedure.
On Error GoTo ErrorHandler

'Creating a message to tell *which* one is missing is left as an exercise
'for the reader, if you wish to.
If wks1 Is Nothing Or wks2 Is Nothing Then
    Err.Raise vbObjectError + 20000, , "Cannot find sheet1 or 2"
End If

'Get the e-mail address that you want to find.
'You don't HAVE to use an InputBox; you could, for instance,
'pick it up from the contents of another cell; that's up
'to you.
vnt_Input = InputBox("Please enter the address that you're looking for", "Address Copier")

'If the user cancels the input box, exit the program.
'Do the same if there's no entry.
'Rather than exiting immediately we jump to the label
'ExitPoint so that all references are cleaned up.
'Perhaps unnecessary, but I prefer good housekeeping.
If vnt_Input = "" Then GoTo ExitPoint

'Find the range containing the e-mail address, if there is one.
'wks1.Cells essentially means "Look in all of the cells in the sheet
'that we assigned to the wks1 variable above". You don't have to be
'on that sheet to do this, you can be in any sheet of the workbook.
Set rng_Found = wks1.Cells.Find(What:=vnt_Input, After:=ActiveCell, _
 LookIn:=xlFormulas, LookAt:=xlPart, SearchOrder:=xlByRows, _
 SearchDirection:=xlNext, MatchCase:=False, SearchFormat:=False)

'The range will be Nothing if the address is not found. In that case, exit.
If rng_Found Is Nothing Then
    MsgBox "Cannot find that address."
    GoTo ExitPoint
End If

'Find the last free row in sheet2
'The .Row property tells us where the used range starts,
'the .Rows property tells us how many to add on to that to 
'find the first free one.
'The only slight problem is that if there are no cells at
'all used in sheet 2, this will return row 2 rather than row
'1, but in practice that may not matter.
'(I wouldn't be surprised if you want headings anyway.)
l_FreeRow = wks2.UsedRange.Row + wks2.UsedRange.Rows.Count

'Make sure that the row is not greater than the number
'of rows on the sheet.
If l_FreeRow > wks2.Rows.Count Then
    Err.Raise vbObjectError + 20000, , "No free rows on sheet " & wks2.Name
End If

'Set a range reference to the target.
'This will be the first free row, column 1 (column A).
Set rng_target = wks2.Cells(l_FreeRow, 1)

'Now copy the entire row that contains the e-mail address
'to the target that we identified above. Note that we DON'T need
'to select either the source range or the target range to do this; in fact
'doing so would just slow the code down.
rng_Found.EntireRow.Copy rng_target

'We always leave the procedure at this point so that we can clear
'all of the object variables (sheets, ranges, etc).
ExitPoint:

On Error Resume Next
Set rng_Found = Nothing
Set wks1 = Nothing
Set wks2 = Nothing
Set rng_target = Nothing
On Error GoTo 0

Exit Sub


ErrorHandler:

MsgBox "Error " & Err.Number & vbCrLf & Err.Description

Resume ExitPoint

End Sub

Answer 2

我将以下代码放在一起，它将查看一系列单元格的内容并将包含某些字符串（在本例中为“@”）的单元格行复制到目标工作簿的新行。

Dim srcWorkbook As Workbook
Dim destWorkbook As Workbook
Dim srcWorksheet As Worksheet
Dim destWorksheet As Worksheet
Dim SearchRange As Range
Dim destPath As String
Dim destname As String
Dim destsheet As String
Set srcWorkbook = ActiveWorkbook
Set srcWorksheet = ActiveSheet

destPath = "C:\test\"
destname = "dest.xlsm"
destsheet = "Sheet1"

'将此设置为您的目标工作簿路径/工作簿名称/工作表名称

On Error Resume Next
Set destWorkbook = Workbooks(destname)
If Err.Number <> 0 Then
    Err.Clear
    Set wbTarget = Workbooks.Open(destPath & destname)
    CloseIt = True
End If

'如果目标工作簿关闭，这将打开它

For Each c In Range("A1:A100").Cells

'将此范围设置为您要检查电子邮件的单元格

If InStr(c, "@") > 0 Then

'在此处设置确定电子邮件地址的计算（目前它只检查@符号）

    c.EntireRow.Copy
    destWorkbook.Activate
    destWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.Select

'这将查找并选择目标表上的下一个空行

Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _
        False, Transpose:=False
    srcWorkbook.Activate
End If
Next

抱歉，如果我弄乱了代码标签，我是该网站的新手 :)

Answer 3

这段代码对于在同一个工作簿上进行复制应该要简单得多，我把我的最后一个答案留在那里，以防你也需要它来跨工作簿工作:)

For Each c In Range("A1:A100").Cells
'SET THIS RANGE TO THE CELLS YOU WANT TO CHECK FOR EMAIL
If InStr(c, "@") > 0 Then
'SET THE CALCULATION FOR DETERMINING AN EMAIL ADDRESS HERE (Currently it just checks for an @ symbol)
c.EntireRow.Copy Destination:=ActiveWorkbook.Worksheets("Sheet2").Range("A" & Rows.Count).End(xlUp).Offset(1)
End If
Next