通过电子邮件search将Excel 2003中的数据行复制并粘贴到其他工作表
在有人说什么之前，我已经浏览了几个与这个类似想法有关的post（按照不同的search标准进行修改，然后修改），但是我不能让macros观工作。 这可能是由于我缺乏编程知识！ 我所要做的就是在WORKSHEET 1中 search一个电子邮件地址，如果发现它，则将整行复制到WORKSHEET 2中的下一个空行。 我正在使用Excel 2003（是的，我是一个老笨蛋！）。
其实我觉得你是一个聪明的人， 我个人憎恨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 我将下面的代码放在一个单元格区域的内容中，并将包含特定string“@”的单元格的行复制到目标工作簿的新行中。
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"
'将此设置为您的目的地问题path/工作簿名称/工作表名称
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
如果closures，这将打开目标工作簿
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
“这将发现并select在目的地表上的下一个空行
Selection.PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, SkipBlanks:= _ False, Transpose:=False srcWorkbook.Activate End If Next
道歉，如果我搞砸了代码标签，我是新来的网站:)
这个代码应该是在同一个工作簿上复制的简单得多，我只是离开我的最后一个答案，因为你需要它跨越工作簿以及:)
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