Kaza,

Try the code below. Copy it in its entirety, and paste into a blank
codemodule. It was written on the assumption that both sheets are named
Sheet1: your explanation and your sample code had conflicting sheet names,
so you will need to fix that. Also, I wasn't sure how many cells around the
"X"cell in Book 1 you wanted to copy: I assumed the cell with X and the
three cells to the right: you can change the .Resize to match reality.

HTH,
Bernie
MS Excel MVP

Option Explicit
Dim d As Range ' All the cells found with what you want

Sub Find_Matches()

Dim rngM As Range
Dim rngN As Range
Dim cellX As Range
Dim cellY As Range
Dim Wbk1 As Workbook
Dim Wbk2 As Workbook
Dim Wbk3 As Workbook

' Get Workbook1
Set Wbk1 = Workbooks.Open(Application.GetOpenFilename(, , "Open File 1"))
With Wbk1.Worksheets("Sheet1")
Set rngN = Intersect(.Columns("E"), .UsedRange)
End With

' Get Workbook1
Set Wbk2 = Workbooks.Open(Application.GetOpenFilename(, , "Open File 2"))
With Wbk2.Worksheets("Sheet1")
Set rngM = Intersect(.Columns("E"), .UsedRange)
End With

Set Wbk3 = Workbooks.Add
Wbk3.SaveAs "Combined.xls"

For Each cellX In rngM
FindValues cellX, rngN
If Not d Is Nothing Then
With Wbk3.Worksheets(1)
d.EntireRow.Copy
.Range("A65536").End(xlUp)(2).PasteSpecial xlValues
cellX.Resize(1, 4).Copy
.Range(.Range("A65536").End(xlUp).End(xlToRight)(1 , 2), _
.Range("A65536").End(xlUp).End(xlToRight)(1, 2) _
.End(xlUp)(2)).PasteSpecial xlValues
End With
End If
Next cellX

End Sub
Sub FindValues(Range1 As Range, Range2 As Range)
Dim c As Range ' The cell found with what you want
Dim myFindString As String
Dim firstAddress As String

Set d = Nothing

myFindString = Range1.Value
With Range2

Set c = .Find(myFindString, LookIn:=xlValues, lookAt:=xlWhole)

If Not c Is Nothing Then
Set d = c
firstAddress = c.Address
End
End If

Set c = .FindNext(c)
If Not c Is Nothing And c.Address < firstAddress Then
Do
Set d = Union(d, c)
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address < firstAddress
End If
End With

End Sub

"Kaza Sriram" wrote in message
om...
hi ,

i am new to the board and also new to VBA , i was wondering if someone
could help me in this following problem in VBA code:

here is the problem description:

I have two spreadsheets in different workbooks ( workbook 1: sheet 1
and workbook2: sheet1), here i need to compare column 5 in Book1 and
Column 5 for all cells, say X is the value we are looking for..

X occurs once in book1 and might occur more than once in book2..so if
a match occurs ( that is once the code checks that there is X occuring
in both books in columns 5) it should copy all rows in book 2 where X
occurs to a new workbook 3 in sheet 1 and also it shoud copy entire
row data where X occurs in book 1 sheet 1 . But this data from book 1
has to be copied at the end of row after the data from book 2 has been
copied.

if X occurs 4 times in book 2 , then 4 rows have to be copied in book
3 and then data from Book 1 where X occurs only once is copied 4 times
at the end of the data from book 2.

this process has to repeated for all cells in columns 5 in book1 and
column 5 in book2 .

i just started on the code and tried my best of programming skills
which is not that great i guess :((

i 'll be grateful if someone can help me on this..below is my code:


Sub Find_Matches()

Dim M, N As Range, x As variant, y As variant
Dim NewRange As Range

' to get the book1 location

MsgBox " Selec the Location of N File"

Application.Dialogs(xlDialogOpen).Show arg1:=""
ActiveWorkbook.Activate

Windows("N.xls").Activate

Sheets("sheetA").Select

Columns("E").Select

Set N = Columns("E")

' to get book 2 location

MsgBox "Select the Location of M File"

Application.Dialogs(xlDialogOpen).Show arg1:=""

ActiveWorkbook.Activate
Sheets("sheetB").Select
Application.ScreenUpdating = False
Columns("E").Select

Set M = Columns("E")

' this is where I am stuck bigtime.!!!!!!!!!!!

For Each x In M

For Each y In N

If cell = y Then y.Offset(0, 1) = y
Set NewRange = Union(Worksheets("sheetB").x.EntireRow,
Worksheets("SheetA").y.EntireRow)
Else
Set NewRange = Nothing

End If

Next y
Next x

' this opens the 3rd work bookbook

Windows("Copy.xls").Activate
Worksheets("Sheets1").Select
NewRange.Copy
ActiveSheet.Paste

Selection.PasteSpecial Paste:=xlValues

Application.CutCopyMode = False
Application.ScreenUpdating = True

End Sub