Compare worksheets from two workbooks

M

michaelg1040

New Member
Joined
Jun 23, 2006
Messages
44
I'm hoping someone can help me with this problem that has been driving me insane! I have a master tracking document that I use to record project information. My client sends me an updated schedule each week which may (or may not) have additional stores on it and some of the details of the stores may have changed. I need a macro to capture these changes from the source spreadsheet (the one the client sends) and update the master tracker. The master tracker has a lot of additional columns of data that I add in myself about each project so I don't want to lose this information. The macro needs to see if the store on the source sheet is already on the master tracker and if it is then it needs to check to see if any of the columns below have changed. If the store isn't on the master tracker then it needs to be added. There are around 750 stores on the master tracker at the moment so to do it manually takes forever!

I hope you can help!

Master Spreadsheet

Column A - Retail Region
Column B - Project Name
Column C - Postcode
Column D - Net Selling Area
Column E - Project Manager
Column F - Contractor
Column I - Start On Site
Column J - Launch Date


Source Spreadsheet

Column C - Retail Region
Column D - Project Name
Column I - Postcode
Column J - Net Selling Area
Column M - Project Manager
Column N - Contractor
Column P - Start On Site
Column Q - Launch Date
 

Excel Facts

Can you AutoAverage in Excel?
There is a drop-down next to the AutoSum symbol. Open the drop-down to choose AVERAGE, COUNT, MAX, or MIN
Sort by date Sort by votes
Try:

Code: 
Sub Test()
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim Rng As Range
    Dim wbMaster As Workbook
    Dim wsMaster As Worksheet
    Dim Cell As Range
    Dim Target As Range
    Dim r As Long
    Set wbSource = Workbooks("Source.xls")
    Set wsSource = wbSource.Worksheets("Sheet1")
    With wsSource
        Set Rng = .Range("D2:D" & .Range("D" & .Rows.Count).End(xlUp).Row)
    End With
    Set wbMaster = Workbooks("Master.xls")
    Set wsMaster = wbMaster.Worksheets("Sheet1")
    For Each Cell In Rng
        With wsMaster
            With .Columns("B")
                Set Target = Nothing
                Set Target = .Find(What:=Cell.Value, After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt _
                   :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
            End With
            If Not Target Is Nothing Then
                r = Target.Row
            Else
                r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            End If
            .Range("A" & r).Value = Cell.EntireRow.Range("C" & 1).Value
            .Range("B" & r).Value = Cell.EntireRow.Range("D" & 1).Value
            .Range("C" & r).Value = Cell.EntireRow.Range("I" & 1).Value
            .Range("D" & r).Value = Cell.EntireRow.Range("J" & 1).Value
            .Range("E" & r).Value = Cell.EntireRow.Range("M" & 1).Value
            .Range("F" & r).Value = Cell.EntireRow.Range("N" & 1).Value
            .Range("I" & r).Value = Cell.EntireRow.Range("P" & 1).Value
            .Range("J" & r).Value = Cell.EntireRow.Range("Q" & 1).Value
        End With
    Next Cell
End Sub

Change the workbook and worksheet references to suit.
 
Upvote 0
Andrew,
Thanks for that, however I'm getting a "Run-time error '9', Subscript out of range" error message when I try to run it.
I've updated the workbook and worksheet references so I'm not sure what the problem is.
This is the code as I've updated it.

Sub UpdateReport()
Dim wbSource As Workbook
Dim wsSource As Worksheet
Dim Rng As Range
Dim wbMaster As Workbook
Dim wsMaster As Worksheet
Dim Cell As Range
Dim Target As Range
Dim r As Long
Set wbSource = Workbooks("\\Sg-data\data\Eden\Client Files\Co-op\Weekly Update File\DevProgrammeReport.xls")
Set wsSource = wbSource.Worksheets("DevProgrammeReport")
With wsSource
Set Rng = .Range("D2:D" & .Range("D" & .Rows.Count).End(xlUp).Row)
End With
Set wbMaster = Workbooks("\\Sg-data\data\Eden\Client Files\Co-op\CO-OP PM Tracker 2010 (2 with pm allocation).xls")
Set wsMaster = wbMaster.Worksheets("CO-OP REFIT PM TRACKER")
For Each Cell In Rng
With wsMaster
With .Columns("B")
Set Target = Nothing
Set Target = .Find(What:=Cell.Value, After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt _
:=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
End With
If Not Target Is Nothing Then
r = Target.Row
Else
r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
End If
.Range("A" & r).Value = Cell.EntireRow.Range("C" & 1).Value
.Range("B" & r).Value = Cell.EntireRow.Range("D" & 1).Value
.Range("C" & r).Value = Cell.EntireRow.Range("I" & 1).Value
.Range("D" & r).Value = Cell.EntireRow.Range("J" & 1).Value
.Range("E" & r).Value = Cell.EntireRow.Range("M" & 1).Value
.Range("F" & r).Value = Cell.EntireRow.Range("N" & 1).Value
.Range("I" & r).Value = Cell.EntireRow.Range("P" & 1).Value
.Range("J" & r).Value = Cell.EntireRow.Range("Q" & 1).Value
End With
Next Cell
End Sub
 
Upvote 0
A workbook must be open to be part of the Workbooks collection. Then you only need its name, not its full path.

Set wbSource = Workbooks("DevProgrammeReport.xls")
 
Upvote 0
I'm using the code and all is working but there is something extra I need it to do which I'm stuck on. The original code looks through the source workbook and updates the master tracker with anything that's missing but it doesn't delete any rows from the master tracker if they have now been removed from the source workbook. Is this something that can be done?
 
Upvote 0
Try:

Code: 
Sub Test()
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim Rng As Range
    Dim wbMaster As Workbook
    Dim wsMaster As Worksheet
    Dim Cell As Range
    Dim Target As Range
    Dim r As Long
    Set wbSource = Workbooks("Source.xls")
    Set wsSource = wbSource.Worksheets("Sheet1")
    With wsSource
        Set Rng = .Range("D2:D" & .Range("D" & .Rows.Count).End(xlUp).Row)
    End With
    Set wbMaster = Workbooks("Master.xls")
    Set wsMaster = wbMaster.Worksheets("Sheet1")
    With wsMaster
        For Each Cell In Rng
            With .Columns("B")
                Set Target = Nothing
                Set Target = .Find(What:=Cell.Value, After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt _
                   :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
            End With
            If Not Target Is Nothing Then
                r = Target.Row
            Else
                r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            End If
            .Range("A" & r).Value = Cell.EntireRow.Range("C" & 1).Value
            .Range("B" & r).Value = Cell.EntireRow.Range("D" & 1).Value
            .Range("C" & r).Value = Cell.EntireRow.Range("I" & 1).Value
            .Range("D" & r).Value = Cell.EntireRow.Range("J" & 1).Value
            .Range("E" & r).Value = Cell.EntireRow.Range("M" & 1).Value
            .Range("F" & r).Value = Cell.EntireRow.Range("N" & 1).Value
            .Range("I" & r).Value = Cell.EntireRow.Range("P" & 1).Value
            .Range("J" & r).Value = Cell.EntireRow.Range("Q" & 1).Value
        Next Cell
        For r = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
            If WorksheetFunction.CountIf(Rng, .Range("b" & r).Value) = 0 Then
                .Rows(r).Delete
            End If
        Next r
    End With
End Sub

Change the workbook and worksheet references to suit.
 
Upvote 0
Andrew,
Thanks for that but it just deletes everything on the master tracker. This is the code as with the references updated - any suggestions?

Code: 
Sub Update_Report()
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim Rng As Range
    Dim wbMaster As Workbook
    Dim wsMaster As Worksheet
    Dim Cell As Range
    Dim Target As Range
    Dim r As Long
    Set wbSource = Workbooks("DevProgrammeReport.xls")
    Set wsSource = wbSource.Worksheets("DevProgrammeReport")
    With wsSource
        Set Rng = .Range("D2:D" & .Range("D" & .Rows.Count).End(xlUp).Row)
    End With
    Set wbMaster = Workbooks("CO-OP PM Tracker 2010 (2 with pm allocation).xls")
    Set wsMaster = wbMaster.Worksheets("CO-OP REFIT PM TRACKER")
    With wsMaster
        For Each Cell In Rng
            With .Columns("B")
                Set Target = Nothing
                Set Target = .Find(What:=Cell.Value, After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt _
                   :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
            End With
            If Not Target Is Nothing Then
                r = Target.Row
            Else
                r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            End If
            .Range("A" & r).Value = Cell.EntireRow.Range("C" & 1).Value
            .Range("B" & r).Value = Cell.EntireRow.Range("D" & 1).Value
            .Range("C" & r).Value = Cell.EntireRow.Range("I" & 1).Value
            .Range("D" & r).Value = Cell.EntireRow.Range("J" & 1).Value
            .Range("E" & r).Value = Cell.EntireRow.Range("M" & 1).Value
            .Range("F" & r).Value = Cell.EntireRow.Range("N" & 1).Value
            .Range("I" & r).Value = Cell.EntireRow.Range("P" & 1).Value
            .Range("J" & r).Value = Cell.EntireRow.Range("Q" & 1).Value
        Next Cell
        For r = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
            If WorksheetFunction.CountIf(Rng, .Range("b" & r).Value) = 0 Then
                .Rows(r).Delete
            End If
        Next r
    End With
    
End Sub

Andrew Poulsom said:
Try:

Code: 
Sub Test()
    Dim wbSource As Workbook
    Dim wsSource As Worksheet
    Dim Rng As Range
    Dim wbMaster As Workbook
    Dim wsMaster As Worksheet
    Dim Cell As Range
    Dim Target As Range
    Dim r As Long
    Set wbSource = Workbooks("Source.xls")
    Set wsSource = wbSource.Worksheets("Sheet1")
    With wsSource
        Set Rng = .Range("D2:D" & .Range("D" & .Rows.Count).End(xlUp).Row)
    End With
    Set wbMaster = Workbooks("Master.xls")
    Set wsMaster = wbMaster.Worksheets("Sheet1")
    With wsMaster
        For Each Cell In Rng
            With .Columns("B")
                Set Target = Nothing
                Set Target = .Find(What:=Cell.Value, After:=.Cells(1, 1), LookIn:=xlFormulas, LookAt _
                   :=xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False)
            End With
            If Not Target Is Nothing Then
                r = Target.Row
            Else
                r = .Cells(.Rows.Count, 1).End(xlUp).Row + 1
            End If
            .Range("A" & r).Value = Cell.EntireRow.Range("C" & 1).Value
            .Range("B" & r).Value = Cell.EntireRow.Range("D" & 1).Value
            .Range("C" & r).Value = Cell.EntireRow.Range("I" & 1).Value
            .Range("D" & r).Value = Cell.EntireRow.Range("J" & 1).Value
            .Range("E" & r).Value = Cell.EntireRow.Range("M" & 1).Value
            .Range("F" & r).Value = Cell.EntireRow.Range("N" & 1).Value
            .Range("I" & r).Value = Cell.EntireRow.Range("P" & 1).Value
            .Range("J" & r).Value = Cell.EntireRow.Range("Q" & 1).Value
        Next Cell
        For r = .Range("B" & .Rows.Count).End(xlUp).Row To 2 Step -1
            If WorksheetFunction.CountIf(Rng, .Range("b" & r).Value) = 0 Then
                .Rows(r).Delete
            End If
        Next r
    End With
End Sub

Change the workbook and worksheet references to suit.
Click to expand...
 
Upvote 0
You must log in or register to reply here.

Similar threads

A
  • Solved
Conditional Formatting - apply rules to multiple rows based on specific cells (drop down menus)
Replies
4
Views
432
AndyB86
A
D
  • Locked
  • Question Question
VBA to copy only matching data from 2 csv workbooks into the "Master Workbook"
Replies
1
Views
315
RoryA
RoryA
gheyman
  • Solved
Comparing two workbooks
Replies
3
Views
692
MountainFog
M
J
  • Question Question
Power Query editor OR VBA to extract data from Grants.gov
Replies
3
Views
295
Jagadeshrao
J
C
  • Question Question
Send Email from Excel - Launch User's Default Email Client
Replies
3
Views
279
Micron
M

Forum statistics

Threads
1,223,277
Messages
6,171,148
Members
452,382
Latest member
RonChand

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top