suppression de doublons en fin de macro [résolu]

[bonjourdoc]

Mmmmh!
Y a un truc qui ne va pas dans mon code.

Private Sub Workbook_Open()
Dim chemin As String    ' classeur regroupé
Dim rep As String       ' répertoire à traiter
Dim fic As String       ' classeur regroupé
Dim ligne As Long       ' ligne écriture
Dim nbc As Integer      ' nombre de classeurs
Dim nbf As Integer      ' nombre de feuilles
Dim nbl As Integer      ' nombre de lignes
Dim mxc As Long         ' maximum colones feuille
Dim c As Integer        ' nombre de colonnes
Dim l As Long           ' ligne lecture
Dim Wf As Worksheet     ' feuille regroupement
Dim Wl As Worksheet     ' feuille regroupée
rep = ThisWorkbook.Path & "\"
Application.ScreenUpdating = False
Application.EnableEvents = False
Application.DisplayAlerts = False
On Error GoTo fin
mxc = Cells(1, ActiveSheet.UsedRange.Columns.Count).End(xlToRight).Column
Set Wf = ThisWorkbook.Sheets("Feuil1")         ' variable feuille groupe
Wf.Cells.ClearContents
nbc = 0: nbf = 0                ' initialisation variables
ligne = 1
fic = Dir(rep & "*.xls")    ' recherche fichiers
While fic <> ""
If fic <> ThisWorkbook.Name Then
    chemin = rep & fic       ' chemin fichiers
        Workbooks.Open chemin, 0  ' ouverture
        Set Wl = ActiveWorkbook.Sheets("JU HEP BEJUNE - Médiathèque de ")
        nbl = Wl.UsedRange.Rows.Count
        c = Wl.UsedRange.Columns.Count
        If ligne > 2 Then l = 2 Else l = 1  ' une seule fois le titre
        Wl.Cells(l, 1).Resize(nbl, c).Copy Destination:=Wf.Cells(ligne, 1)
        ligne = ligne + nbl - l + 1
        nbf = nbf + 1
        ActiveWorkbook.Close SaveChanges:=False   ' Fermeture du classeur
        nbc = nbc + 1
End If
    fic = Dir
Wend
    For l = ligne To 2 Step -1
        If Wf.Cells(l, mxc).End(xlToLeft).Column = 1 _
            And Wf.Cells(l, 1).Value = "" Then
            Wf.Rows(l).Delete
            ligne = ligne - 1
        End If
    Next l
fin:
    MsgBox nbc & " classeurs regroupés avec " & nbf & " feuilles et " & ligne & " lignes"
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.DisplayAlerts = True

' tri_supprimerDoublons Macro
'

'
    ActiveWindow.SmallScroll Down:=-102
    Range("A2").Select
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("A2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("A2:P182")
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveSheet.Range("$A$1:$P$182").RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, _
        7, 8, 9, 10, 11, 12, 13, 14, 15, 16), Header:=xlYes
End Sub

Le début est ok. Mes fichier .xls s'additionnent.
La deuxième partie " tri_supprimerDoublons" n'est pas encore au point.
J'ai donc utilisé l'enregistreur de marco pour effectuer "selectionner tout" > trier A-Z > supprimer les doublons.

2 problèmes:

J'ai effectué cet enregistrement de macro lorsque j'avais compilé 8 fichiers .xls comptant 182 lignes.
Lorsque j'ai ajouté un 9e et un 10e fichier, tout n'était pas pris en compte pour le " tri_supprimerDoublons", puisque celui-ci s'exécutait jusqu'à la ligne 182.
Et comme ma macro prend en compte 182 lignes, mes fichiers 9 et 10 viennent s'ajouter dès la ligne 183.

D'autres fichiers s'ajoutent chaque jour.

Mon but est que ma macro " tri_supprimerDoublons" prenne d'abord en compte la liste entière de mes fichiers à compiler, puis trie et finalement efface tous les doublons.

 

[pierrejean]

Re : suppression de doublons en fin de macro

Bonjour bonjourdoc

A tester:

ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Clear
    ActiveWorkbook.Worksheets("Feuil1").Sort.SortFields.Add Key:=Range("A2"), _
        SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
    x = ActiveWorkbook.Worksheets("Feuil1").Range("A" & Rows.Count).End(xlUp).Row
    With ActiveWorkbook.Worksheets("Feuil1").Sort
        .SetRange Range("A2:P" & x)
        .Header = xlNo
        .MatchCase = False
        .Orientation = xlTopToBottom
        .SortMethod = xlPinYin
        .Apply
    End With
    ActiveSheet.Range("$A$1:$P$" & x).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5, 6, _
        7, 8, 9, 10, 11, 12, 13, 14, 15, 16), Header:=xlYes

 

[bonjourdoc]

Re : suppression de doublons en fin de macro

Bonjour pierrejean,

Cela semble fonctionner parfaitement. Encore un test avec les nouveaux fichiers qui arriveront demain.

Mille mercis.