Vérification des doublons

Salut le forum,

Je sollicite votre aide afin d'améliorer une macro qui fait le transfert des données depuis la feuille 1 (après saisie) à la feuille 4

Les données sur la feuille 1 sont organisées sous forme des plages, chaque plage est identifiée par un acronyme

Je souhaite avant de faire le transfert des données avoir un contrôle sur la date (date sur la feuille 1 "C26" qui correspond à la colonne statut dans le tableau sur la feuille 4) et l'acronyme

si la date sur la feuille 1 = la date de la colonne A sur le tableau dans la feuille 4 et l'acronyme est identique sur les deux feuilles

alors un message box apparaissait pour deux choix :

soit Oui pour remplacer les anciens par les nouvelles données.

ou Non pour arrêter la macro de transfert

je vous remercie d'avance pour votre aide, mon fichier exemple ci-joint

Bonjour,

pourriez-vous svp me donner un coup de main

enfaite, j'ai besoin d'une macro qui me permet de faire le contrôle des lignes doublon sur le tableau

Si la date sur la colonne "A" et l'acronyme sur la colonne "C" sont répétés alors un message Box apparaissait "Voulez-vous écraser les données déjà sauvegarde"

avec deux possibilités

soit oui pour suppression de la première ligne en double

Hello,

Voici une proposition (ça ne gère que des lignes en doubles, pas les triplons, quadruplons ect ... )

Public Function SupprimeDoublon(strTheDate As String, strAcronyme As String) As Boolean

    Dim loBdd As ListObject
    Dim strConcat As String
    Dim varReponse As Variant
    Dim lrRow As ListRow
    Dim colRowNumber As Collection

    Set loBdd = ActiveSheet.ListObjects("BD_TODO")
    strConcat = strTheDate & strAcronyme
    For Each lrRow In loBdd.ListRows
        If lrRow.Range(1).Value & lrRow.Range(3).Value = strConcat Then
            If colRowNumber Is Nothing Then
                Set colRowNumber = New Collection
                colRowNumber.Add CStr(lrRow.Range.Row)
            Else
                colRowNumber.Add CStr(lrRow.Range.Row)
            End If
        End If
    Next lrRow
    If Not colRowNumber Is Nothing Then
        If colRowNumber.Count = 2 Then
            varReponse = _
                    MsgBox("Des lignes en doubles sont présentes concernant la date du : " & strTheDate & _
                    " et de l'acronyme : " & strAcronyme & vbNewLine & _
                    "Voulez-vous écraser les données déjà sauvegarde ?", vbYesNo)
            If varReponse = vbYes Then
                ActiveSheet.Rows(CInt(colRowNumber(1))).Delete
            Else
                ActiveSheet.Rows(CInt(colRowNumber(2))).Delete
            End If
        Else 'rien à faire
        End If
    Else 'rien à faire
    End If
    Set loBdd = Nothing
    Set colRowNumber = Nothing

End Function

Hi @Rag02700,

merci pour la proposition, mais je pense que "strTheDate" non définie

ainsi pourriez-vous svp me dire comme fonctionne Public Function

bonjour Niba

Sub Supprimer_Doublons()
     Dim LO, i, b, Ligne, sAnsw, aA, cnt
     With Sheets("feuil4")                   'votre feuille
          Set LO = .ListObjects("BD_TODO")   'votre tableau
          LO.ListColumns("Date").DataBodyRange.Name = "MaDate"     'colonne des dates
          LO.ListColumns("Acronyme").DataBodyRange.Name = "MonAcronyme"     'colonnes des acronymes

          Do                                 'boucle
               For i = 1 To LO.ListRows.Count     'boucle toutes les lignes
                    b = (WorksheetFunction.CountIfs(Range("MaDate"), Range("MaDate").Cells(i, 1), Range("MonAcronyme"), Range("MonAcronyme").Cells(i, 1)) > 1)     'compte doublons de date et d'acronyme
                    If b Then                'si doublons
                         aA = Application.Transpose(Evaluate(Replace(Replace("if((madate=#)*(monacronyme=@),row(madate),""~"")", "#", Range("MaDate").Cells(i, 1).Value2), "@", Chr(34) & Range("MonAcronyme").Cells(i, 1).Value & Chr(34))))
                         fl = Filter(aA, "~", 0)     'matrice avec les lignes "doublons"
                         sAnsw = Application.InputBox("il y a des doublons sur les lignes " & Join(fl, ", ") & vbLf & vbLf & "P=supprimer le premier : " & fl(0) & vbLf & "D=supprimer le dernierer : " & fl(UBound(fl)) & vbLf & vbLf & "A=Arrêter", "Supprimer les doublons", "P", , , , , 2)
                         Select Case UCase(sAnsw)
                              Case "A": GoTo FIN     'arrêter
                              Case "P": Ligne = fl(0)     'supprimer le premier
                              Case "D": Ligne = fl(UBound(fl))     'supprimer le dernier
                              Case Else: Ligne = "x"     'créer non-numeric
                         End Select
                         If IsNumeric(Ligne) Then LO.ListRows(Ligne - LO.Range.Row).Delete: cnt = cnt + 1     'supprimer listrow et incrementer compteur
                         Exit For
                    End If
               Next
          Loop While b
     End With

FIN:
     MsgBox "on a supprimé " & cnt & " lignes"
End Sub

même solution avec "oui" et "non"

Bonjour @BsAlv,

Merci pour vos solution, celle de "oui" et "non" me convient parfaitement, malgré que l'autre est originale