Recopiage de donnée dans une ligne sans doublon. VBA

[Bert]

Bonjour à tous,

J'espère que ma question trouvera réponse grâce à vous.
Je dispose d'une liste client dans une feuille de calcul.
Grace à une macro j'aimerai pour la colonne "site de prélèvement" envoyer les données dans la feuille de calcul "site" en fonction de chaque client en ligne. Et ce sans créer des doublons.

Voici le code que j'ai tapé:
Quand j’exécute j'ai une erreur de compilation 424 "Objet requis".
Je ne parviens pas à voir les erreurs dans le code.

Merci d'avance si vous me donnez vos idées ou si vous trouvez la solution!

Sub Site()

Dim i, c, j As Integer
Dim a, b As String

i = Worksheets("Echantillons").Range("A2").Row
' i : Ligne de la première cellule dans ech à vérifier
a = Worksheets("Echantillons").Cells(i, 1).Value 
' Valeur du client dans ech
b = Worksheets("Echantillons").Cells(i, 5).Value
 ' Valeur du site dans ech
c = Application.VLookup(a, Worksheets("Site").Range("A2:A100000"), 1, False).Row
' Numéro de la ligne dans worksheets site de la valeur du site

Do While a <> ""
' tant qu'il reste des client dans la liste de la feuille echantillon
j = 2
Do While Cells(c, j) <> ""
'Tant que la cellule dans la feuille site est différent de rien
If Cells(c, j).Value = b Then GoTo FIN1 'si il trouve la valeur, on écrit pas le doublon
If Cells(c, j).Value = "" Then 'si il ne trouve pas la valeur il l'écrit dans la ligne à la suite
Cells(c, j).Value = b
GoTo FIN1
End If
j = j + 1 ' il continue de chercher dans la ligne
Loop

FIN1:

i = i + 1 ' il procède ainsi pour toutes les ligne de la feuille  Echantillon
Loop

End Sub

 

[Bebere]

Re : Recopiage de donnée dans une ligne sans doublon. VBA

bonjour Bert
bienvenue
un code qui fonctionne
si tu as unne erreur avec c= Application.Match(a, Rng, 0)
mettre des données correctes dans échantillons

Sub Site()

Dim i As Long, b As Variant, c As Long, j As Long
Dim a As String, Rng As Range
Set Rng = Worksheets("Site").Range("A1:A" & Worksheets("Site").Range("A65536").End(xlUp).Row)
With Worksheets("Echantillons")
For i = 2 To .Range("A65536").End(xlUp).Row
'i = .Range("A2").Row
' i : Ligne de la première cellule dans ech à vérifier
a = .Cells(i, 1).Value ' Valeur du client dans ech
b = .Cells(i, 5).Value ' Valeur du site dans ech
'c = Application.VLookup(a, Worksheets("Site").Range("A2:A100000"), 1, False).Row
c = Application.Match(a, Rng, 0) '.Row
' Numéro de la ligne dans worksheets site de la valeur du site
 If c > 0 And Worksheets("Site").Cells(c, b + 1).Value = "" Then
'    MsgBox "Aucune occurence trouvée de " & c & " ...", , Titre
'    Exit Sub
'    Else
Worksheets("Site").Cells(c, b + 1).Value = .Cells(i, 6).Value  'inscrit prélèvement
  Else
  c = Worksheets("Site").Range("A65536").End(xlUp).Row + 1
  Worksheets("Site").Cells(c, 1) = a
  Worksheets("Site").Cells(c, b + 1) = .Cells(c, 6)
  End If
  Next i
  End With
'Do While a <> ""
'' tant qu'il reste des client dans la liste de la feuille echantillon
'j = 2
'Do While Worksheets("Site").Cells(c, j) <> ""
''Tant que la cellule dans la feuille site est différent de rien
'If Worksheets("Site").Cells(c, j).Value = b Then GoTo FIN1 'si il rouve la valeur, on écrit pas la doublon
'If Worksheets("Site").Cells(c, j).Value = "" Then 'si il ne trouve pas la valeur il l'écrit dans la ligne à la suite
'Worksheets("Site").Cells(c, j).Value = b
'GoTo FIN1
'End If
'j = j + 1 ' il continue de chercher dans la ligne
'Loop
'
'FIN1:
'
'i = i + 1 ' il procède ainsi pour toutes les ligne de la feuille  Echantillon
'Loop

End Sub

 

[néné06]

Re : Recopiage de donnée dans une ligne sans doublon. VBA

Bonjour Bert,

J'ai regardé un peu ton fichier, mais je ne trouve pas la feuille "LISTE" et "PDF" ?
Si tu pouvais vérifier et nous faire parvenir la mouture avec ces deux feuilles manquantes, nous pourrions mieux suivre l'évolution de ton programme .

A te relire

René

EDIT: Salut Bebere

 

[Bert]

Re : Recopiage de donnée dans une ligne sans doublon. VBA

Bonjour,

Merci à vous deux pour vos réponses!

Néné06 je te joins le fichier complet.
Mais normalement tu n'as pas besoin de ces onglets.

A bientôt,

Cordialement,