compare two ranges in different workbooks and copy data to a new workbook

[Kaza Sriram]

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

 

[Bernie Deitrick]

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]

hi Bernie,

the code doesn't do anything..the combined.xls remains blank...i dont
know why is doing so, i am trying to debug..if nothing works....u know
what i'll make a two sample spreadsheets and send them to u ..so that
u can see better abt the working of code...
pls see if u can do anything...so u have anyemail where i can send the
spreadsheets..??

thanks a tonn for all help..!!)

regards,

kaza

 

[Bernie Deitrick]

Kaza,

Fix the email address here by taking out spaces and replacing the dot with a
..

HTH,
Bernie
MS Excel MVP

 

[Kaza Sriram]

Bernie,

i just sent u an email...did u receive it..?? otherwise send me an
email at the id: (e-mail address removed)

thanks,

kaza

 

[Bernie Deitrick]

Kaza,

No, I didn't get it, so I will send you one now...

HTH,
Bernie
MS Excel MVP

 

[Kaza Sriram]

hi Bernie,

hi Bernie,

the macro doesnt nor match these:

project no 405208 and system no 405208-WA..there r lots of rows like
this and should match..

also the format is jumbled up..actually book 1 has around 65 rows and
book 2 has around 25 rows

the data has to be pasted in book 3 like this:

first data from book 2 having 25 rows and then data from book 1 having
65 rows

please can u help me out in this..

thanks a lottt,

kaza

 

[Bernie Deitrick]

Kaza,

You are probably opening the files in reverse order.

HTH,
Bernie
MS Excel MVP