2 tableau a comparer et rajou si difference

Bonjour,
j ai un probleme sous exl j ai deux tableau un de plus 4000 noms et un de plus de 2500 noms
http://www.cijoint.fr/cjlink.php?file=cj200912/cijvE0glbB.xls
http://www.cijoint.fr/cjlink.php?file=cj200912/cijvE0glbB.xls

ce que je voudrais c est qu exel compare les tableau en fonction des donnees si une des des donnees du tableau de 2500 noms existent dans le tableau de 4000 noms il copie le no of vet de la colone de fichier 4000 vers la meme colone vide actuellement du fichier 2500

j ai tente ca
Option Explicit

Sub Compare()
Dim Sh1CompareRange As Variant, Sh2CompareRange As Variant
Dim ws1 As Worksheet, ws2 As Worksheet, ws3 As Worksheet
Dim c1, c2, c3, sp, x1, x2, v
Set ws1 = Worksheets(1)
Set ws2 = Worksheets(2)
Set ws3 = Worksheets(3)

Application.ScreenUpdating = False
' *** il serait bien de vider la feuille 3 avant de commencer
Sheets("sheet3").Cells.ClearContents
' Récupérer les 2 plages à comparer
Set Sh1CompareRange = ws1.Range("A1:A" & ws1.Range("A1").End(xlDown).Row)
Set Sh2CompareRange = ws2.Range("A1:A" & ws2.Range("A1").End(xlDown).Row)
With ws1
For Each c1 In Sh1CompareRange
' copier sytématique de la ligne ws1
' Boucle sur ligne feuille 1; colonne: A,B,C,D,E et F
' copie sur feuille 3; colonne : A,B,C,D,E et F
For x1 = 1 To 8
ws3.Cells(c3 + 1, x1) = .Cells(c1.Row, x1)
Next x1
' référence en O temporaire pour trier
ws3.Cells(c3 + 1, 15) = .Cells(c1.Row, 1)
'si c1 exciste sur ws2 , copier
If 1 = WorksheetFunction.CountIf(Sh2CompareRange, c1) Then
c2 = WorksheetFunction.Match(c1, Sh2CompareRange, 0)
' Boucle sur ligne feuille 2; colonne: A,B,C,D,E et F
' copie sur feuille 3; colonne : H,I,J,K,L et M
' laisser une colonne G vide
For x2 = 1 To 8
ws3.Cells(c3 + 1, 9 + x2) = ws2.Cells(c2, x2)
Next x2
End If
' puis --> contrôler si c2 n'est pas dans ws1 copier +1 ligne en ws3
v = Sh2CompareRange(c1.Row, 1)
If 0 = WorksheetFunction.CountIf(Sh1CompareRange, v) Then
' Boucle ligne f2; colonne: A,B,C,D,E et F
' copie sur f3, ligne suivante; colonne : H,I,J,K,L et M
' colonne G vide
c3 = c3 + 1
For x2 = 1 To 8
ws3.Cells(c3 + 1, 9 + x2) = ws2.Cells(c1.Row, x2)
Next x2
' référence en O temporaire pour trier
ws3.Cells(c3 + 1, 15) = ws2.Cells(c1.Row, 1)
End If
c3 = c3 + 1
' End If
Next c1
End With
' si Sh2Comp... est plus grand que sh1Comp... traiter le surplus de Sh2Comp...
If Sh2CompareRange.Count > Sh1CompareRange.Count Then
For sp = Sh1CompareRange.Count + 1 To Sh2CompareRange.Count
If 0 = WorksheetFunction.CountIf(Sh1CompareRange, Sh2CompareRange(sp, 1)) Then
' Boucle ligne f2; colonne: A,B,C,D,E et F
' copie sur f3, ligne suivante; colonne : H,I,J,K,L et M
' colonne G vide
For x2 = 1 To 8
ws3.Cells(c3 + 1, 9 + x2) = ws2.Cells(sp, x2)
Next x2
' référence en O temporaire pour trier
ws3.Cells(c3 + 1, 15) = ws2.Cells(sp, 1)
c3 = c3 + 1
End If

Next sp
End If
' trier et supprimer colonne [o] temporaire
ws3.Cells.Sort Key1:=ws3.Columns("O"), Order1:=xlDescending, Header:=xlGuess
ws3.Columns("O:O").Clear
Application.ScreenUpdating = True
End Sub

que j avais dev pour un autre boulot avec l aide d une commencamarche-iste
pour comparer et a la limite finir le travail a la main mais la j ai un probleme c est qu il ne me donne pas le bon resultat

voila si quelau una une idee

Configuration: Windows XP Internet Explorer 7.0