Copy & Paste row of data in Excel 2003 to differen

Question

Before anybody says anything, I have looked through several of the posts relating to this similar idea (going by different search criterial and then modifying it) but I can't get the macro to work. This is probably due to my lack of programming knowledge! All I want to do is, search for an email address in WORKSHEET 1 and if it finds it, copy the whole row to the next free row in WORKSHEET 2. I'm using Excel 2003 (yes I'm an old stick-in-the-mud!).

Answer 1

This Code should be a lot simpler for doing the copy on the same workbook, I'm leaving my last answer there just incase you need it to work across workbooks as well :)

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

Answer 2

Actually I think you're a smart person; personally I detest 2007/2010's user interface for many reasons.

To answer your question, see whether this make sense. (It's quick and dirty so it isn't bullet-proofed. It should give you a starting point, though.)

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 3

I have put together the following code which will look at the contents of a range of cells and copy the rows of cells that contain certain strings, "@" in this case, to a new row of a target workbook.

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"

'SET THIS TO YOUR DESTINATION WORBOOK Path/Workbook Name/Worksheet Name

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

'THIS OPENS THE DESTINATION WORKBOOK IF IT IS CLOSED

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
    destWorkbook.Activate
    destWorkbook.Sheets(1).Range("A" & Rows.Count).End(xlUp).Offset(1).EntireRow.Select

'THIS FINDS AND SELECTS THE NEXT EMPTY ROW ON THE DESTINATION SHEET

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

Apologies if i have messed up the code tags, I'm new to the site :)