Search and Compare two Workbooks

[DireWolf]

I want to run a macro to search through one workbook and find the
corresponding entry in another work book and enter the row details in
a new workbook if one of the other cells in the row does not match.

The real data I have is two product price lists.

So I want to be able to through through column A which has the product
code in the first worksheet and find the matching product code in the
second.

Once a match is found I want to check the corresponding row for Column
B which has the price. If there is any difference I want to have the
row from the first workbook copied and pasted into a new workbook.
This will give me a list of products that have a change in price.

Also if there is not a matching product code I want to also copy that
row into a third workbook on a different sheet. Plus reverse the
seach from the second workbook to the first. What this will do is
give me a list of new products and a list of old (obsolete) products.

Here is what I think I'm after in persudo code

WB1 = workbook1
WB1A = workbook1, column A
WB1B == workbook1, column B
WB2 = workbook2
WB1A = workbook2, column A
WB1B == workbook2, column B
WB3 = workbook3
WB3price_change = workbook3, worksheet 'price_change'
WB3new_product == workbook3, workshhet 'new_product'
WB3old_product == workbook3, workshhet 'old_product'



while WB1A is not empty
search WB1A
find matching row in WB2A
if WB1B = WB2B continue
if WB1B != WB2B
then copy row WB1A
Paste into WB3price_change
if WB1A finds no match in WB2A
then copy row WB1A
Paste into WB3new_product
goto start

while WB2A is not empty
search WB2A
find matching row in WB1A
if match found, continue
if WB2A finds no match in WB1A
then copy row WB2A
paste into WB3old_product
goto start

 

[mudraker]

This code assumes all 3 workbooks are already open


Sub CheckPrices()
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Ws3 As Worksheet

Dim Ws1A As Range
Dim Ws2A As Range

Dim lWb1Row As Long
Dim lWb2Row As Long
Dim lws3VacRow As Long

Dim Cell As Range

Dim sProd As String

Set Ws1 = Workbooks("Book3").Sheets("Sheet1")
Set Ws2 = Workbooks("Book4").Sheets("Sheet1")
Set Ws3 = Workbooks("Book5").Sheets("Sheet1")

Set Ws1A = Ws1.Columns("A")
Set Ws2A = Ws2.Columns("A")

' compare book 1 against book 2
For Each Cell In Ws1.Range("A1:a" & Range("a65536").End(xlUp).Row)
lWb2Row = 0
If Not IsEmpty(Cell) Then
On Error Resume Next
lWb2Row = Ws2A.Find(What:=Cell.Value, After:=ActiveCell,
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlNext, _
MatchCase:=False).Row
On Error GoTo 0
If lWb2Row > 0 Then
If Ws1.Range("b" & Cell.Row) <> Ws2.Range("b" & lWb2Row)
Then
lws3VacRow = Ws3.Range("a65536").End(xlUp).Row + 1
Ws3.Range("a" & lws3VacRow).Value = Cell.Value
End If
Else
lws3VacRow = Ws3.Range("a65536").End(xlUp).Row + 1
Ws3.Range("a" & lws3VacRow).Value = Cell.Value
End If
End If
Next Cell

'compare book 2 against book 1
For Each Cell In Ws1.Range("A2:a" & Range("a65536").End(xlUp).Row)
lWb1Row = 0
If Not IsEmpty(Cell) Then
On Error Resume Next
lWb1Row = Ws2A.Find(What:=Cell.Value, After:=ActiveCell,
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlNext, _
MatchCase:=False).Row
On Error GoTo 0
If lWb1Row > 0 Then
If Ws2.Range("b" & Cell.Row) <> Ws1.Range("b" & lWb1Row)
Then
lws3VacRow = Ws3.Range("a65536").End(xlUp).Row + 1
Ws3.Range("a" & lws3VacRow).Value = Cell.Value
End If
Else
lws3VacRow = Ws3.Range("a65536").End(xlUp).Row + 1
Ws3.Range("a" & lws3VacRow).Value = Cell.Value
End If
End If

Next Cell

End Sub

 

[DireWolf]

Thanks for the reply mudraker

I get an error when I run the macro and viewing the code in the VB
editor I see these offending parts in red

lWb2Row = Ws2A.Find(What:=Cell.Value, After:=ActiveCell,
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows,
SearchDirection:=xlNext, _
MatchCase:=False).Row

and


If Ws1.Range("b" & Cell.Row) <> Ws2.Range("b" & lWb2Row)
Then

 

[mudraker]

Direwolf


With the code that you pasted in this message It looks like my code has
been word wrapped at some stage.

When a _ is at the end of a line VBA joins the next line of code to
the previous to make up a continous single command



New code has _ added to 2 lines

lWb2Row = Ws2A.Find(What:=Cell.Value, After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False).Row


Put the Then at the end ot the If statment row

eg If(balh<>blahblah) then


If Ws1.Range("b" & Cell.Row) <> Ws2.Range("b" & lWb2Row)
Then

 

[DireWolf]

ahhh now that makes sense.

As you can tell I don't know very much VB. I can do a bit of php so
I can relate that rule.

When I run the macro I get this error:
runtime error 9, subscript out of range

on this line of code:
Set Ws1 = Workbooks("book1").Sheets("Sheet1")

I'm assuming that it can't set the Ws1 variable as it has a problem
with the workbook?

I have my 3 workbooks (named - book1, book2, book3) open, the
worksheet in each is named "Sheet1". Do I need to define anything
else or is the problem with my workbooks?

Thanks for the help so far.

 

[mudraker]

DireWolf

The workbook name will need to be set to the fulll workbook name eg
Book1.xls



Set Ws1 = Workbooks("book1").Sheets("Sheet1")
would work only if the workbook Book1 had never been saved once it has
been saved the workbookname becomes Book1.xls

try

Set Ws1 = Workbooks("book1.xls").Sheets("Sheet1")

 

[DireWolf]

Yep that fixed that problem

When I run the macro from workbook1, all the data from workbook1
column A is pasted into workbook3 twice. As in two blocks of data,
one for each of the checks in the code.

When I run the macro from workbook2, all the data from workbook1
column A is pasted into workbook three. for any items that are
different in workbook1, they are pasted underneath. So the second
part works ok apart from only column A data being pasted into
workbook3.

My eyes are hanging out of my head so I will go get some sleep and
give this another go tomorrow. I haven't tested this with data that
is not in the same order or anything as yet. I will have a play
around and see what I can come up with.

Meanwhile, can you shed any light on why only column A is pasted into
worksheet3? I would like to have the whole row copied in.

Cheers

 

[mudraker]

DireWolf

Sorry I forgot you wanted the entire row my code only copied column A


this same instruction needs to be replaced in 2 locations

Ws3.Range("a" & lws3VacRow).Value = Cell.Value

to


1st change
ws1.rows(Cell.row).copy Destination:=Ws3.Rows(lws3VacRow)


2nd change
ws2.rows(Cell.row).copy Destination:=Ws3.Rows(lws3VacRow

Some Products will be listed twice as macro checks book1 product
against book 2 products and lists diffences in book3

it then does the same for checking book 2 against book 1

Just in case I am misunderstanding your problem please paste all o
your cod

 

[DireWolf]

These are the test and results from running the macro.

Test: book1 and book2 with identical products and prices.
Expected Result: should find no difference so nothing written to
book3.
Actual Result: every row from book1 was written to book3

Test: book1 has one additional product compared to book2
Expected Result: row containing additional product written to book3
Actual Result - run from book1: all rows from book1 written to book3
followed by all rows from book2 from after the corresponding product
in book1 (i.e. new product was in row 5 of book1 so all products from
row 5 down in book2 were written to book3)
Actual Result - run from book2: all rows from book1 written to book3
apart from last row, followed by all rows book2 from after the
corresponding product in book1

Test: book1 has one product with different price compared to book2
Expected Result: row containing product with different price from
book1 written to book3
Actual Result -run from book2: All rows from book1 written to book3
followed by corresponding row of changed price row from book2 written
to book3
Actual Result - run from book1: All rows from book1 are written to
book3 followed by all rows from book2.

When I mix up the order of products I get products all over the place.
I'm still trying to workout where they are coming from for that test.

Here is the complete code


Sub CheckPrices()

Sub CheckPrices()
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Ws3 As Worksheet

Dim Ws1A As Range
Dim Ws2A As Range

Dim lWb1Row As Long
Dim lWb2Row As Long
Dim lws3VacRow As Long

Dim Cell As Range

Dim sProd As String

Set Ws1 = Workbooks("book1.xls").Sheets("Sheet1")
Set Ws2 = Workbooks("book2.xls").Sheets("Sheet1")
Set Ws3 = Workbooks("book3.xls").Sheets("Sheet1")

Set Ws1A = Ws1.Columns("A")
Set Ws2A = Ws2.Columns("A")

' compare book 1 against book 2
For Each Cell In Ws1.Range("A1:a" & Range("a65536").End(xlUp).Row)
lWb2Row = 0
If Not IsEmpty(Cell) Then
On Error Resume Next
lWb2Row = Ws2A.Find(What:=Cell.Value, After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False).Row_
On Error GoTo 0
If lWb2Row > 0 Then
If Ws1.Range("b" & Cell.Row) <> Ws2.Range("b" & lWb2Row) Then
lws3VacRow = Ws3.Range("a65536").End(xlUp).Row + 1
Ws1.Rows(Cell.Row).Copy Destination:=Ws3.Rows(lws3VacRow)
End If
Else
lws3VacRow = Ws3.Range("a65536").End(xlUp).Row + 1
Ws1.Rows(Cell.Row).Copy Destination:=Ws3.Rows(lws3VacRow)
End If
End If
Next Cell


'compare book 2 against book 1
For Each Cell In Ws1.Range("A2:a" & Range("a65536").End(xlUp).Row)
lWb1Row = 0
If Not IsEmpty(Cell) Then
On Error Resume Next
lWb1Row = Ws2A.Find(What:=Cell.Value, After:=ActiveCell, _
LookIn:=xlFormulas, _
LookAt:=xlPart, SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False).Row
On Error GoTo 0
If lWb1Row > 0 Then
If Ws2.Range("b" & Cell.Row) <> Ws1.Range("b" & lWb1Row) Then
lws3VacRow = Ws3.Range("a65536").End(xlUp).Row + 1
Ws2.Rows(Cell.Row).Copy Destination:=Ws3.Rows(lws3VacRow)
End If
Else
lws3VacRow = Ws3.Range("a65536").End(xlUp).Row + 1
Ws2.Rows(Cell.Row).Copy Destination:=Ws3.Rows(lws3VacRow)
End If
End If

Next Cell

End Sub

 

[mudraker]

DireWolf

I have changed a fair bit of my original code.

This will be a little slower (if you have a large number of entries t
compare.


Full code posted here - please watch for word wraps.

Have added a couple extra lines of code to highlight in book 3 wha
data is different between book1 & book2
Book1 to book2 = blue text
Book2 to book1 = red text


If you have a large number a entries to check and you find that this i
to slow let me know and I will re write it using arrays which wil
greatly icrease the checking speed



Sub CheckPrices()
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Ws3 As Worksheet

Dim Ws1A As Range
Dim Ws2A As Range

Dim lWb1Row As Long
Dim lWb2Row As Long
Dim lws3VacRow As Long

Dim Cell1 As Range
Dim Cell2 As Range

Dim sProd As String

Set Ws1 = Workbooks("book1.xls").Sheets("Sheet1")
Set Ws2 = Workbooks("book2.xls").Sheets("Sheet1")
Set Ws3 = Workbooks("book3.xls").Sheets("Sheet1")

Set Ws1A = Ws1.Columns("A")
Set Ws2A = Ws2.Columns("A")

' compare book 1 against book 2
For Each Cell1 In Ws1.Range("A1:a" & Range("a65536").End(xlUp).Row)
lWb2Row = 0
If Not IsEmpty(Cell1) Then
For Each Cell2 In Ws2.Range("A1:a" & Range("a65536").End(xlUp).Row)
If Cell1.Value = Cell2.Value Then
If Ws2.Range("b" & Cell2.Row) <> Ws1.Range("b" & Cell1.Row) Then
lws3VacRow = Ws3.Range("a65536").End(xlUp).Row + 1
Ws1.Rows(Cell1.Row).Copy Destination:=Ws3.Rows(lws3VacRow)
Ws3.Range("a" & lws3VacRow).Font.ColorIndex = 0
Ws3.Range("b" & lws3VacRow).Font.ColorIndex = 5
End If
lWb2Row = Cell2.Row
Exit For
End If
Next Cell2
If lWb2Row = 0 Then
lws3VacRow = Ws3.Range("a65536").End(xlUp).Row + 1
Ws1.Rows(Cell1.Row).Copy Destination:=Ws3.Rows(lws3VacRow)
Ws3.Range("a" & lws3VacRow).Font.ColorIndex = 5
Ws3.Range("b" & lws3VacRow).Font.ColorIndex = 0
End If
End If
Next Cell1


' compare book 2 against book 1
For Each Cell2 In Ws2.Range("A1:a" & Range("a65536").End(xlUp).Row)
lWb1Row = 0
If Not IsEmpty(Cell1) Then
For Each Cell1 In Ws1.Range("A1:a" & Range("a65536").End(xlUp).Row)
If Cell1.Value = Cell2.Value Then
If Ws2.Range("b" & Cell2.Row) <> Ws1.Range("b" & Cell1.Row) Then
lws3VacRow = Ws3.Range("a65536").End(xlUp).Row + 1
Ws2.Rows(Cell1.Row).Copy Destination:=Ws3.Rows(lws3VacRow)
Ws3.Range("a" & lws3VacRow).Font.ColorIndex = 0
Ws3.Range("b" & lws3VacRow).Font.ColorIndex = 3
End If
lWb1Row = Cell1.Row
Exit For
End If
Next Cell1
If lWb1Row = 0 Then
lws3VacRow = Ws3.Range("a65536").End(xlUp).Row + 1
Ws2.Rows(Cell2.Row).Copy Destination:=Ws3.Rows(lws3VacRow)
Ws3.Range("a" & lws3VacRow).Font.ColorIndex = 3
Ws3.Range("b" & lws3VacRow).Font.ColorIndex = 3
End If
End If
Next Cell2
End Su

 

[DireWolf]

Wow, this new code is really starting to do the trick.

I have anywhere between 500 and 1000 rows to process, but I don't care
if it takes 5 minutes to run as it has got to be better than doing it
manually (as I do now). Thanks for the help so far, its going to save
me a heap of time.

No column headings (row 1 from book1) are written to book3 as they
were before. I can live without them as I can just paste them in when
its run.

These tests worked spot on:

Test: both book1 and book2 contain identical data
Expect Result: nothing is written to book3
Actual Result: as expected

Test: both book1 and book2 contain identical data but rows are in
different order
Expected Result: nothing is written to book3
Actual Result: as expected

Test: book1 contains one product with different price
Expected Result: row from book1 with different price written to book3
Actual result: as expected

Test: book1 has one new product and one product removed
Expected Result: new product from book1 and old product from book2
written to book3
Actual Result: as Expected

Test: book1 has one additional product
Expected Result: row containing additional product is written to book3
Actual Result - run from book1: as expected
Actual Result - run from book2: nothing is written to book3


These two threw up a couple of unexpected rows:

Test: book1 has one product removed
Expected result: row from book2 containing removed product written to
book3
Actual Result: Last row from book1 followed by missing product from
book2 is written to book3

Test: book1 has 12 new products and one changed product
Expected Result: 12 new products and one changed product from book1
written to book3
Actual Result: as expected but 4th product (row5) from book2 is
written to last row in book3

 

[mudraker]

DireWolf

To add Column Header from book1 row 1 to book 3 row 1 inseart

this one line of code after the Dim & Set instructions

Ws1.Rows(1).Copy Destination:=Ws3.Rows(1)


-------

Sub CheckPrices()

Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Ws3 As Worksheet

Dim Ws1A As Range
Dim Ws2A As Range

Dim lWb1Row As Long
Dim lWb2Row As Long
Dim lws3VacRow As Long

Dim Cell1 As Range
Dim Cell2 As Range

Dim sProd As String

Set Ws1 = Workbooks("book1.xls").Sheets("Sheet1")
Set Ws2 = Workbooks("book2.xls").Sheets("Sheet1")
Set Ws3 = Workbooks("book3.xls").Sheets("Sheet1")

Set Ws1A = Ws1.Columns("A")
Set Ws2A = Ws2.Columns("A")

Ws1.Rows(1).Copy Destination:=Ws3.Rows(1)

' compare book 1 against book 2
For Each Cell1 In Ws1.Range("A1:a" & Range("a65536").End(xlUp).

How often will you run this macro

 

[DireWolf]

cool thanks for that.

I will run this macro at least once per week, but sometimes 3 times a
week.

This is going to make a nightmare job of checking 500-1000 rows of
data so much nicer.

 

[DireWolf]

Ok I ran the macro on lthe actual data tonight and it worked like a
charm.

for around 500 rows it took 18 seconds to run, which is not too bad.

One thing I found I did was I split the results into different
workbooks as they need to be imported that way into another
application. If I wanted to write the results to different workbooks
then I assume I would change these line to the new worksheet

Ws3.Range("a" & lws3VacRow).Font.ColorIndex = 0
Ws3.Range("b" & lws3VacRow).Font.ColorIndex = 5

to

Ws4.Range("a" & lws3VacRow).Font.ColorIndex = 0
Ws4.Range("b" & lws3VacRow).Font.ColorIndex = 5

Other than that it looks great! Thanks a million!

 

[DireWolf]

Worked it out and it does it all. The only down side is that it now
takes about 40 seconds to loop through the 500 odd rows. It still I
heap quicker than doing it by hand so I am happy.

Anyway here is the final code

Sub CheckPrices()

' set these variables
Dim Ws1 As Worksheet
Dim Ws2 As Worksheet
Dim Ws3 As Worksheet
Dim Ws4 As Worksheet
Dim Ws5 As Worksheet
Dim Ws6 As Worksheet

Dim Ws1A As Range
Dim Ws2A As Range

Dim lWb1Row As Long
Dim lWb2Row As Long
Dim lws3VacRow As Long
Dim lws4VacRow As Long
Dim lws5VacRow As Long
Dim lws6VacRow As Long

Dim Cell1 As Range
Dim Cell2 As Range

Dim sProd As String

Set Ws1 = Workbooks("book1.xls").Sheets("Sheet1")
Set Ws2 = Workbooks("book2.xls").Sheets("Sheet1")
Set Ws3 = Workbooks("book3.xls").Sheets("Sheet1")
Set Ws4 = Workbooks("book4.xls").Sheets("Sheet1")
Set Ws5 = Workbooks("book5.xls").Sheets("Sheet1")
Set Ws6 = Workbooks("book6.xls").Sheets("Sheet1")

Set Ws1A = Ws1.Columns("A")
Set Ws2A = Ws2.Columns("A")

' copy the column heading to book3, 4 , 5 & 6
Ws1.Rows(1).Copy Destination:=Ws3.Rows(1)
Ws1.Rows(1).Copy Destination:=Ws4.Rows(1)
Ws1.Rows(1).Copy Destination:=Ws5.Rows(1)
Ws1.Rows(1).Copy Destination:=Ws6.Rows(1)

' compare book 1 against book 2
For Each Cell1 In Ws1.Range("A1:a" & Range("a65536").End(xlUp).Row)
lWb2Row = 0
If Not IsEmpty(Cell1) Then
For Each Cell2 In Ws2.Range("A1:a" & Range("a65536").End(xlUp).Row)
If Cell1.Value = Cell2.Value Then
If Ws2.Range("b" & Cell2.Row) <> Ws1.Range("b" & Cell1.Row) Then
lws3VacRow = Ws3.Range("a65536").End(xlUp).Row + 1
Ws1.Rows(Cell1.Row).Copy Destination:=Ws3.Rows(lws3VacRow)
Ws3.Range("a" & lws3VacRow).Font.ColorIndex = 0
Ws3.Range("b" & lws3VacRow).Font.ColorIndex = 5
End If
lWb2Row = Cell2.Row
Exit For
End If
Next Cell2
If lWb2Row = 0 Then
lws4VacRow = Ws4.Range("a65536").End(xlUp).Row + 1
Ws1.Rows(Cell1.Row).Copy Destination:=Ws4.Rows(lws4VacRow)
Ws4.Range("a" & lws4VacRow).Font.ColorIndex = 5
Ws4.Range("b" & lws4VacRow).Font.ColorIndex = 0
End If
End If
Next Cell1

' compare book 2 against book 1
For Each Cell2 In Ws2.Range("A1:a" & Range("a65536").End(xlUp).Row)
lWb1Row = 0
If Not IsEmpty(Cell1) Then
For Each Cell1 In Ws1.Range("A1:a" & Range("a65536").End(xlUp).Row)
If Cell1.Value = Cell2.Value Then
If Ws2.Range("b" & Cell2.Row) <> Ws1.Range("b" & Cell1.Row) Then
lws5VacRow = Ws5.Range("a65536").End(xlUp).Row + 1
Ws2.Rows(Cell1.Row).Copy Destination:=Ws5.Rows(lws5VacRow)
Ws5.Range("a" & lws5VacRow).Font.ColorIndex = 0
Ws5.Range("b" & lws5VacRow).Font.ColorIndex = 3
End If
lWb1Row = Cell1.Row
Exit For
End If
Next Cell1
If lWb1Row = 0 Then
lws6VacRow = Ws6.Range("a65536").End(xlUp).Row + 1
Ws2.Rows(Cell2.Row).Copy Destination:=Ws6.Rows(lws6VacRow)
Ws6.Range("a" & lws6VacRow).Font.ColorIndex = 3
Ws6.Range("b" & lws6VacRow).Font.ColorIndex = 3
End If
End If
Next Cell2

End Sub