VBA - Transférer des données sans avoir de doublons

Bonjour,

Je souhaite transférer des données d'une feuille à une autre, mais seulement les données qui ne sont pas inscrites dans le tableau principal sur la feuille "Menu pointage". Pour ce faire j'ai ajouté une colonne à ma feuille requête afin de savoir si la ligne en question est déjà présente dans l'autre tableau. Sauf que cela marche une fois et ensuite mon programme transfert les lignes déjà transférées.

J'ai essayé plusieurs codes mais jamais je n'arrive au résultat recherché qui est de transférer uniquement les lignes qui ne sont pas déjà présentes dans ce tableau.

Voici mon code :

Sub Actualiser()

    Sheets("Requête").Visible = True
    Sheets("Requête").Select

    Set LstObj = ActiveSheet.ListObjects("Tableau2")

'Filtre

LstObj.Range.AutoFilter Field:=7, Criteria1:="<>*Oui*"

'Transfert des lignes sur la feuille "Menu pointage"
    Range("Tableau2[[Date]:[temps]]").Select
    Selection.Copy

Sheets("Menu pointage").Select
Range("A10000").End(xlUp).Offset(1).Select 'Aller à la première cellule vide
Selection.PasteSpecial Paste:=xlPasteValues, operation:=xlNone, skipblanks:=False, Transpose:=False 'Coller la sélection
Range("Tableau1[Date]").Select 'Sélectionné la colonne Date du tableau
    Selection.NumberFormat = "d/m/yyyy" 'Mettre le format français

Sheets("Requête").Select
ActiveSheet.ListObjects("Tableau2").Range.AutoFilter Field:=7
ActiveWindow.SelectedSheets.Visible = False

ActiveWorkbook.Worksheets("Menu pointage").ListObjects("Tableau1").Sort. _
        SortFields.Clear
    ActiveWorkbook.Worksheets("Menu pointage").ListObjects("Tableau1").Sort. _
        SortFields.Add2 Key:=Range("Tableau1[[#All],[Date]]"), SortOn:= _
        xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Menu pointage").ListObjects("Tableau1").Sort
        .Header = xlYes
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With

Range("A1").Select

End Sub

voici mon fichier :

Merci pour votre aide

Loïs

Bonjour LRK50, le forum,

Pour le transfert, un essai....avec une approche différente...

Je stocke les lignes contenant NON dans une variable tableau puis je les écris dans la feuille de destination.

Sub Actualiser()
 Dim lo_pointage As ListObject, lo_requete As ListObject
 Dim rcell As Range
 Dim tb, ntb(), i&, j%, k&

  Set lo_pointage = Sheets("Menu pointage").ListObjects(1)
   Set lo_requete = Sheets("Requête").ListObjects(1)
    If Not lo_requete.DataBodyRange Is Nothing Then
     tb = lo_requete.DataBodyRange
    Else
     MsgBox "Le tableau source est vide !", vbExclamation: Exit Sub
    End If

  With lo_pointage
   If .InsertRowRange Is Nothing Then
    Set rcell = .HeaderRowRange.Cells(1).Offset(.ListRows.Count + 1)
   Else
    Set rcell = .InsertRowRange.Cells(1)
   End If
  End With

  k = 0
  ReDim ntb(0 To UBound(tb, 1), 1 To 6)
   For i = 1 To UBound(tb, 1)
    If UCase(tb(i, 7)) = "NON" Then
     For j = 1 To 6
      ntb(k, j) = tb(i, j)
     Next j
     k = k + 1
    End If
   Next i

 If k > 0 Then
  rcell.Resize(k, 6) = ntb
 Else
  MsgBox "Aucune(s) donnée(s) à transférer !", vbExclamation
 End If

 Erase tb: Erase ntb: Set rcell = Nothing
End Sub

Cordialement,

Xorsankukai,

Merci pour cette solution qui fonctionne parfaitement

Bonne soirée :)

Bonjour,

Merci pour le retour et pour avoir passé le sujet en résolu,

Bonne continuation.