Home |
Search |
Today's Posts |
#1
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Compare two Workbooks
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 |
#2
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Compare two Workbooks
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 --- Message posted from http://www.ExcelForum.com/ |
#3
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Compare two Workbooks
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 On Tue, 6 Jan 2004 00:32:36 -0600, mudraker wrote: 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 --- Message posted from http://www.ExcelForum.com/ |
#4
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Compare two Workbooks
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 --- Message posted from http://www.ExcelForum.com/ |
#5
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Compare two Workbooks
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. On Tue, 6 Jan 2004 16:26:52 -0600, mudraker wrote: 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 --- Message posted from http://www.ExcelForum.com/ |
#6
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Compare two Workbooks
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") --- Message posted from http://www.ExcelForum.com/ |
#7
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Compare two Workbooks
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 On Tue, 6 Jan 2004 20:04:27 -0600, mudraker wrote: 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") --- Message posted from http://www.ExcelForum.com/ |
#8
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Compare two Workbooks
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 -- Message posted from http://www.ExcelForum.com |
#9
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Compare two Workbooks
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 On Wed, 7 Jan 2004 18:25:34 -0600, mudraker wrote: 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 products 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 of your code --- Message posted from http://www.ExcelForum.com/ |
#10
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Compare two Workbooks
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 -- Message posted from http://www.ExcelForum.com |
#11
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Compare two Workbooks
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 On Thu, 8 Jan 2004 15:36:21 -0600, mudraker wrote: 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 to compare. Full code posted here - please watch for word wraps. Have added a couple extra lines of code to highlight in book 3 what 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 is to slow let me know and I will re write it using arrays which will 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 Sub --- Message posted from http://www.ExcelForum.com/ |
#12
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Compare two Workbooks
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 -- Message posted from http://www.ExcelForum.com |
#13
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Compare two Workbooks
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. :) On Sun, 11 Jan 2004 18:55:14 -0600, mudraker wrote: 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? --- Message posted from http://www.ExcelForum.com/ |
#14
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Compare two Workbooks
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! On Sun, 11 Jan 2004 18:55:14 -0600, mudraker wrote: 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? --- Message posted from http://www.ExcelForum.com/ |
#15
Posted to microsoft.public.excel.programming
|
|||
|
|||
Search and Compare two Workbooks
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 On Sun, 11 Jan 2004 18:55:14 -0600, mudraker wrote: 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? --- Message posted from http://www.ExcelForum.com/ |
Reply |
Thread Tools | Search this Thread |
Display Modes | |
|
|
Similar Threads | ||||
Thread | Forum | |||
Need help with formula to search and compare data in different col | Excel Worksheet Functions | |||
Compare workbooks | Excel Discussion (Misc queries) | |||
Search / Compare / Copy Value Up (cpm) | Excel Discussion (Misc queries) | |||
Compare workbooks | Excel Discussion (Misc queries) | |||
compare different workbooks | Excel Worksheet Functions |