Hi everyone,
I have 2 sheets in a workbook.
Sheet1 has 14 fields and first 4 are unique
Sheet2 has 21 fields and first 4 are unique (say equal to sheet1)
Now, How to pick each row from sheet1 (4 fields) find their equals in sheet2
collect those equal rows and put in a new workbook and close with a new name.

Any help on this please (code or links).

This is the kind of thing. You'll want to amend it (unless you're happy to
wait for a couple of hours!) as it currently compares all empty cells too.
It also pastes to a sheet in the same workbook (sheet3) rather than a
workbook:

Sub PasteMatches()
Dim cell1 As Range
Dim cell2 As Range
For Each cell1 In Worksheets("Sheet1").Columns(1).Cells
For Each cell2 In Worksheets("Sheet2").Columns(1).Cells
If cell2.Value & cell2.Offset(0, 1).Value & cell2.Offset(0, 2).Value
& cell2.Offset(0, 3).Value = cell1.Value & cell1.Offset(0, 1).Value &
cell1.Offset(0, 2).Value & cell1.Offset(0, 3).Value Then
cell2.EntireRow.Copy
Worksheets("Sheet3").Activate
Range("A1").CurrentRegion.Select
Selection.Offset(Selection.Rows.Count).Resize(1, 1).Select
ActiveSheet.Paste
End If
Next cell2
Next cell1
End Sub

"Eddy Stan" wrote:

Hi everyone,
I have 2 sheets in a workbook.
Sheet1 has 14 fields and first 4 are unique
Sheet2 has 21 fields and first 4 are unique (say equal to sheet1)
Now, How to pick each row from sheet1 (4 fields) find their equals in sheet2
collect those equal rows and put in a new workbook and close with a new name.

Any help on this please (code or links).

boss it didn't work. each time it gives different error.
and it did write even one matching in sheet3.
Can you try please.
Further the code runs more up to 4 min for 5 rows in sheet1 and 1000 rows in
sheet2

"Martin" wrote:

This is the kind of thing. You'll want to amend it (unless you're happy to
wait for a couple of hours!) as it currently compares all empty cells too.
It also pastes to a sheet in the same workbook (sheet3) rather than a
workbook:

Sub PasteMatches()
Dim cell1 As Range
Dim cell2 As Range
For Each cell1 In Worksheets("Sheet1").Columns(1).Cells
For Each cell2 In Worksheets("Sheet2").Columns(1).Cells
If cell2.Value & cell2.Offset(0, 1).Value & cell2.Offset(0, 2).Value
& cell2.Offset(0, 3).Value = cell1.Value & cell1.Offset(0, 1).Value &
cell1.Offset(0, 2).Value & cell1.Offset(0, 3).Value Then
cell2.EntireRow.Copy
Worksheets("Sheet3").Activate
Range("A1").CurrentRegion.Select
Selection.Offset(Selection.Rows.Count).Resize(1, 1).Select
ActiveSheet.Paste
End If
Next cell2
Next cell1
End Sub

"Eddy Stan" wrote:

Hi everyone,
I have 2 sheets in a workbook.
Sheet1 has 14 fields and first 4 are unique
Sheet2 has 21 fields and first 4 are unique (say equal to sheet1)
Now, How to pick each row from sheet1 (4 fields) find their equals in sheet2
collect those equal rows and put in a new workbook and close with a new name.

Any help on this please (code or links).

Hi Martin,
your code is not giving error or not giving answer to my problem.
Can you try with your own example and send me your sample excel sheet to


Thanks for your try...

"Martin" wrote:

This is the kind of thing. You'll want to amend it (unless you're happy to
wait for a couple of hours!) as it currently compares all empty cells too.
It also pastes to a sheet in the same workbook (sheet3) rather than a
workbook:

Sub PasteMatches()
Dim cell1 As Range
Dim cell2 As Range
For Each cell1 In Worksheets("Sheet1").Columns(1).Cells
For Each cell2 In Worksheets("Sheet2").Columns(1).Cells
If cell2.Value & cell2.Offset(0, 1).Value & cell2.Offset(0, 2).Value
& cell2.Offset(0, 3).Value = cell1.Value & cell1.Offset(0, 1).Value &
cell1.Offset(0, 2).Value & cell1.Offset(0, 3).Value Then
cell2.EntireRow.Copy
Worksheets("Sheet3").Activate
Range("A1").CurrentRegion.Select
Selection.Offset(Selection.Rows.Count).Resize(1, 1).Select
ActiveSheet.Paste
End If
Next cell2
Next cell1
End Sub

"Eddy Stan" wrote:

Hi everyone,
I have 2 sheets in a workbook.
Sheet1 has 14 fields and first 4 are unique
Sheet2 has 21 fields and first 4 are unique (say equal to sheet1)
Now, How to pick each row from sheet1 (4 fields) find their equals in sheet2
collect those equal rows and put in a new workbook and close with a new name.

Any help on this please (code or links).

Hello - somebody talk to me, I am desperate for excel code.

"Eddy Stan" wrote:

Hi Martin,
your code is not giving error or not giving answer to my problem.
Can you try with your own example and send me your sample excel sheet to


Thanks for your try...

"Martin" wrote:

This is the kind of thing. You'll want to amend it (unless you're happy to
wait for a couple of hours!) as it currently compares all empty cells too.
It also pastes to a sheet in the same workbook (sheet3) rather than a
workbook:

Sub PasteMatches()
Dim cell1 As Range
Dim cell2 As Range
For Each cell1 In Worksheets("Sheet1").Columns(1).Cells
For Each cell2 In Worksheets("Sheet2").Columns(1).Cells
If cell2.Value & cell2.Offset(0, 1).Value & cell2.Offset(0, 2).Value
& cell2.Offset(0, 3).Value = cell1.Value & cell1.Offset(0, 1).Value &
cell1.Offset(0, 2).Value & cell1.Offset(0, 3).Value Then
cell2.EntireRow.Copy
Worksheets("Sheet3").Activate
Range("A1").CurrentRegion.Select
Selection.Offset(Selection.Rows.Count).Resize(1, 1).Select
ActiveSheet.Paste
End If
Next cell2
Next cell1
End Sub

"Eddy Stan" wrote:

Hi everyone,
I have 2 sheets in a workbook.
Sheet1 has 14 fields and first 4 are unique
Sheet2 has 21 fields and first 4 are unique (say equal to sheet1)
Now, How to pick each row from sheet1 (4 fields) find their equals in sheet2
collect those equal rows and put in a new workbook and close with a new name.

Any help on this please (code or links).

Eddy,

I have just emailed you a workbook l am developing as ad Excel Add-In
that will do what you want. However the 2 lists will need to be copied
side by side to another sheet.

Regards

Michael beckinsale