Copy Rows between sheets

[bucklee]

I have worksheet1, worksheet2 and worksheet3 and I am trying to have excel do a compare of a cell in worksheet3 against a cell in worksheet2 and if a match is found copy the entire row of worksheet2 to worksheet1.
<?xml:namespace prefix = o ns = "urn:schemas-microsoft-comfficeffice" /><o></o>
Worksheet1
Header row that matches header row in worksheet2
<o></o>
Worksheet2
Column A = Asset Name
Column B = Asset Location
Column C = Asset Owner
<o></o>
Worksheet3
Column D = Asset Name
<o></o>
So if any cell in ws3 Column D matches any cell in ws2 Column A I want to copy the entire row from ws2 to ws1 (starting in row 2).
<o></o>
I would like this to be done automatically if possible and as you can probably tell I’m not versed in VBA.
<o></o>
Thanks for any help on my issue,
<o></o>
Lee

 

[bucklee]

I found this out on the web based on the description it should work. As I stated in my previous post I do not know VBA that stated I have a couple of questions. Where in this code do I plug in which column I want to compare and could you provide an example for instance compare sheet2 column A to sheet3 column D?

Thanks for any input.



Private Sub cmdSearch_Click()
Dim DestSheet As Worksheet
Set DestSheet = Worksheets("Sheet3")
Dim r1 As Range, r2 As Range
Dim r3 As Range, r4 As Range
Dim cell As Range
Dim sRow As Long 'source Row
Dim dRow As Long 'destination row
Dim sCount As Long
' assume you data in sheet1 and sheet2 start in row 2
sRow = 2
' if that isn't the case, change the 2 in the command
' above to reflect the first row with data in sheet1 & 2
With Worksheets("Sheet2")
Set r2 = .Range(.Cells(sRow, 9), .Cells(Rows.Count, 9).End(xlUp))
End With 'bucklee I assume I need to plug in something different above but was confused as to where
With Worksheets("Sheet3")
Set r1 = .Range(.Cells(sRow, 9), .Cells(Rows.Count, 9).End(xlUp))
End With 'bucklee I assume I need to plug in something different above but was confused as to where
For Each cell In r1
If Application.CountIf(r2, cell) > 0 Then
If r3 Is Nothing Then
Set r3 = cell.Offset(0, -8)
Else
Set r3 = Union(r3, cell.Offset(0, -8))
End If
End If
Next
If Not r3 Is Nothing Then
Set r4 = DestSheet.Cells(Rows.Count, 1).End(xlUp)
If Not IsEmpty(r4) Then Set r4 = r4(2)
r3.EntireRow.Copy r4
Else
MsgBox "No matches found"
End If
End Sub

 

[Legacy 14611]

hey lee

try this and see if it does the job

Sub trythis()
Dim n2 As Long, n3 As Long, cla2, cld3
Dim i As Long, p As Long
With Sheets("Sheet2")
    n2 = .Cells(Rows.Count, "a").End(xlUp).Row
    cla2 = .Cells(1, "a").Resize(n2)
End With
With Sheets("Sheet3")
    n3 = .Cells(Rows.Count, "d").End(xlUp).Row
    cld3 = .Cells(1, "d").Resize(n3)
End With
With CreateObject("Scripting.Dictionary")
    For i = 2 To n3
        .Item(cld3(i, 1)) = Empty
    Next
    For i = 2 To n2
        If .exists(cla2(i, 1)) Then
            p = p + 1
            Sheets("Sheet2").Rows(i).Copy Sheets("sheet1").Cells(p + 1, 1)
        End If
    Next
End With
End Sub

 

[bucklee]

Thank you very much for posting this worked as written. I may have to write more of these in the future if are there any recommended books out there that you know of.

 

[Legacy 14611]

Lee,

Glad that it worked OK.

Re Excel, VBA, etc books, I don't know much about these (never read one), but I think there's one's by Bill Jelen and by John Walkenbach reputed to be OK.

There also seems a fair bit of stuff on the MrExcel homepage about learning etc. resources, which you might check out, and quite a lot of posts on this forum indicate sometimes interesting ways to deal with all kinds of oddball and other Excel problems.