Broogle,

Here is the revised code
These go into the Sheet2' events
Private Sub Worksheet_Activate()
SynchronizeSheets
UpdateSheet
End Sub

Private Sub Worksheet_Change(ByVal Target As Range)
If Not Intersect(Target, Sheet2.Columns("B:B")) Is Nothing Or _
Not Intersect(Target, Sheet2.Columns("C:C")) Is Nothing Then
UpdateCollection
End If
End Sub

These go into the module
Global gCol As New Collection

Sub UpdateCollection()
Dim r&, bError As Boolean
With Sheet2
For r = 1 To .UsedRange.Rows.Count
If .Cells(r, 2).Value < "" Then

bError = False
On Error Resume Next
gCol.Add Item:=.Cells(r, 3).Value, Key:=.Cells(r, 2).Value
bError = (Err < 0)
On Error GoTo 0

If bError Then
'existing item. Change the value associated with it.
gCol.Remove (.Cells(r, 2).Value)
gCol.Add Item:=.Cells(r, 3).Value, Key:=.Cells(r, 2).Value
End If
End If
Next r
End With
End Sub
Sub UpdateSheet()

Dim r&
Application.EnableEvents = False
With Sheet2
For r = 1 To .UsedRange.Rows.Count
If .Cells(r, 2).Value < "" Then
On Error Resume Next
.Cells(r, 3).Value = gCol(.Cells(r, 2).Value)
On Error GoTo 0
End If
Next r
End With
Application.EnableEvents = True

End Sub
Sub SynchronizeSheets()

Dim r&
Application.EnableEvents = False
With Sheet2
'Clear the two columns
With .Range(.Cells(1, 2), .Cells(.UsedRange.Rows.Count, 3))
.ClearContents
End With
For r = 1 To Sheet1.UsedRange.Rows.Count
.Cells(r, 2).Value = Sheet1.Cells(r, 2).Value
Next r
End With
Application.EnableEvents = True

End Sub

And this goes into the Workbook_Open
Private Sub Workbook_Open()
UpdateCollection
End Sub

Hope this works completely.

Alok Joshi
"broogle" wrote:

Thanks Alok!
I really appreaciate your time.

I can email you my worksheet if you want to.

Cheers
broogle