Répartition d'une liste doublons dans différentes feuilles

Bonjour Ô très chers experts

J'ai un feuille excel qui contient l'historique des situations de personnes (ex : leurs différentes adresses postales qui ont changé) et elles peuvent donc apparaître plusieurs fois.

Pour un traitement ultérieur, je ne dois pas avoir plusieurs fois la même personne dans un même onglet.

J'ai écris le code ci-dessous parcours mon tableau, créé un onglet dès qu'il trouve un doublon et écrit les lignes tant qu'il ne trouve pas de nouveau doublon. Mon code écrit aussi si la ligne a été traitée ou non.

Cependant, mon code créé trop d'onglets donc ça ne fait pas ce que je veux...sinon je ne serais pas venu ici !

Si j'avais dans mon onglet d'historique, les lignes : PAUL, PAUL, PAUL, PIERRE, PIERRE, JEAN

j'obtiens 4 onglets : 1)PAUL - 2)PAUL - 3)PAUL, PIERRE - 4) PIERRE, JEAN

Et moi je voudrais : 1)PAUL, PIERRE, JEAN - 2)PAUL, PIERRE - 3) PAUL mais je sèche

Merci d'avance pour vos lumières

Sub azerty()
    num_Onglet = 0
    ligne_a_ecrire = 1
    With Sheets("Historique_")
        For i = 5 To 12
            ancienneValeur = .Range("B" & i - 1).Value
            nouvelleValeur = .Range("B" & i).Value
            aTraiter = .Range("D" & i).Value 'Permet de savoir si la colonne a été traitée -> "OK" = ligne traitée

            If (nouvelleValeur = ancienneValeur) Or num_Onglet = 0 Then
                num_Onglet = num_Onglet + 1
                Worksheets.Add.Name = "Histo_" & num_Onglet
                .Range("A4:C4").Copy Sheets("Histo_" & num_Onglet).Range("A1")
                ligne_a_ecrire = 1
            End If

            If aTraiter = "OK" Then
                ligne_a_ecrire = ligne_a_ecrire - 1
            Else
                 ligne_a_ecrire = ligne_a_ecrire + 1
                 .Range("A" & i & ":C" & i).Copy Sheets("Histo_" & num_Onglet).Range("A" & ligne_a_ecrire)
                .Range("S" & i).Value = "OK"

            End If
        Next
    End With

End Sub

Bonjour clementptpf ,

Et il est où le classeur avec les données et le code ?

Bonjour

Un essai à tester. Te convient-il ?

Bye !

Re ,

Parfait le classeur.

Un essai dans le fichier joint. Le code (à ma sauce) est dans Module1.

On n'utilise plus de dictionary donc les possesseurs de machine Apple pourront l'exécuter.

...

Re,

Je n'ai pas fait attention à la taille des en-têtes. Préférez cette version V1b (une seule ligne de code a changé).

Bonjour gmb et mafraise,

@mafraise : je n'ai pas mis de fichier au début car certains en veulent et d'autres non. Mais je note que pour une prochaine fois, je mettrai le code ET un fichier, comme ça chacun prend ce qu'il veut

@gmb/@mafraise : merci pour vos retours. J'ai testé rapidement, ça semble faire ce que je voulais mais je vais regarder en détail ce soir afin de bien comprendre (et avoir refaire qq chose de similaire), et en l'appliquant dans mon fichier. Je vous tiens au courant.

C'est nickel.

Pour ne pas dire que j'ai rien fait, j'ai apporté 3 ajouts lors de la création des feuilles pour mettre des filtres, nommer le tableau et ajuster largeurs de colonnes

         Worksheets("F" & i).Range("a1").AutoFilter
         Worksheets("F" & i).Range("a1:f1").Columns.AutoFit
         .ListObjects.Add(xlSrcRange, .Range("a1").CurrentRegion, , xlYes).Name = "Tbl_F" & i

Encore merci à tous le 2

bonjour mafraise,clementptpf,gmb,

une autre proposition

Sub ventiler2()
     Dim arr, i, c

    Application.ScreenUpdating = False
     Application.DisplayAlerts = False
     For i = Worksheets.Count To 1 Step -1
          If UCase(Worksheets(i).Name) Like "OCCUR-*" Then Worksheets(i).Delete
     Next i
     Application.DisplayAlerts = True

     With Sheets("Feuil1")
          If .FilterMode Then .ShowAllData
          Set c = .Range("A1").CurrentRegion
          With c
               .Name = "clement"
               arr = Evaluate("transpose(unique(offset(clement,,1,,1)))") 'les Occur uniques
               For i = 2 To UBound(arr)
                    .AutoFilter 2, arr(i)
                    Sheets.Add after:=Sheets(Sheets.Count)
                    With ActiveSheet
                         c.Copy .Range("A1")
                         .Range("A1").CurrentRegion.EntireColumn.AutoFit
                         .Name = arr(i)
                         .ListObjects.Add(xlSrcRange, .Range("a1").CurrentRegion, , xlYes).Name = "Tbl_" & arr(i)
                    End With
               Next
               .AutoFilter
               Application.Goto .Range("A1")
          End With
     End With
     Application.ScreenUpdating = False
End Sub

Bonjour Bart,

J'avais oublié de te remercier pour ta proposition !

Je vais la tester également.