Suppression doublons BD 27Colonnes x NLignes
Bonsoir,
En fait, au fil de mes recherches j'avais trouvé une macro que j'ai adapté pour mes besoins. Elle m'a toujours donné satisfaction, jusqu'à dernièrement.
Je rassemble des feuilles de données, sur une seule feuille et je dois supprimer les lignes en doubles en ne tenant pas compte de la 2ème colonne. En effet, je ne dois considérer comme doublons que les lignes ayant des valeurs identiques en col1 et de Col3 à Col27.
D'après ce que j'ai pu lire, le procédé le plus rapide est l'utilisation des tableaux que je ne maitrise pas du tout.
Pourriez-vous s'il vous plait me venir en aide? l'idée est au sein même du code que j'utilisais. Concaténer les données en utilisant un tableau, puis utiliser un dictionnaire pour enlever les doublons et remettre le tout sur la feuille et si c'est possible renuméroter les lignes de la colonne 2.
Même si mon idée est bonne, je n'ai pas les compétences pour la traduire en code.
Sub SuppDoublonBD()
'Concaténation cellules en colonne 52 sauf colonne 2 n'est pas prise en compte
'col2 doit être renuméroter (non fait)
Dim nbL As Long, wb As Worksheet
Set wb = Worksheets("BD")
Set mondico = CreateObject("Scripting.Dictionary")
Application.EnableEvents = False
Application.ScreenUpdating = False
temps = Timer
With wb
nbL = Application.WorksheetFunction.CountA(Range("b2:b65000"))
'concatene les cellules en colonne 52
NoLig = 2
For i = 0 To nbL
.Cells(NoLig + i, 52) = .Cells(NoLig + i, 1) & .Cells(NoLig + i, 3) & .Cells(NoLig + i, 4) & _
.Cells(NoLig + i, 5) & .Cells(NoLig + i, 6) & .Cells(NoLig + i, 7) & .Cells(NoLig + i, 8) & _
.Cells(NoLig + i, 9) & .Cells(NoLig + i, 10) & .Cells(NoLig + i, 11) & .Cells(NoLig + i, 12) & _
.Cells(NoLig + i, 13) & .Cells(NoLig + i, 14) & .Cells(NoLig + i, 15) & .Cells(NoLig + i, 16) & _
.Cells(NoLig + i, 17) & .Cells(NoLig + i, 18) & .Cells(NoLig + i, 19) & .Cells(NoLig + i, 20) & _
.Cells(NoLig + i, 21) & .Cells(NoLig + i, 22) & .Cells(NoLig + i, 23) & .Cells(NoLig + i, 24) & _
.Cells(NoLig + i, 25) & .Cells(NoLig + i, 26) & .Cells(NoLig + i, 27)
Next
i = i + 1
'+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
i = 2
Do While Cells(i, "A") <> ""
If Not mondico.Exists(.Cells(i, "A") & .Cells(i, "AZ")) Then
mondico(.Cells(i, "A") & .Cells(i, "AZ")) = ""
i = i + 1
Else
.Rows(i).EntireRow.Delete
End If
Loop
.Columns(52).Delete
End With
Application.ScreenUpdating = True
Application.EnableEvents = True
MsgBox Timer - temps
End Subavec ce code, je ne m'en sors plus, ça prend énormément de temps (avec mon vieux micro +de 7mn)
En vous remerciant par avance.
Cordialement,
Bonjour,
Une proposition, 0.43s chez moi :
Option Explicit
Sub SuppDoublonBD()
Dim derlig As Long, lig As Long, datas As Variant, result() As Variant
Dim clé As String, col As Long, lig2 As Long
Dim Dict, t As Single
Set Dict = CreateObject("Scripting.Dictionary")
t = Timer
'recup datas
With Worksheets("BD")
derlig = .Cells(Rows.Count, "A").End(xlUp).Row
datas = .[A2].Resize(derlig - 1, 27)
End With
' clés
For lig = 1 To UBound(datas)
clé = datas(lig, 1)
For col = 3 To 27
clé = clé & datas(lig, col)
Next col
Dict(clé) = Dict(clé) + 1
datas(lig, 2) = Dict(clé) ' numérotation des doublons
Next lig
' liste résultats
For lig = 1 To UBound(datas)
If datas(lig, 2) = 1 Then 'recup doublon n°1
lig2 = lig2 + 1
ReDim Preserve result(1 To 27, 1 To lig2)
For col = 1 To 27
result(col, lig2) = datas(lig, col)
Next col
result(2, lig2) = lig2 ' nouvelle numérotation ligne
End If
Next lig
' nettoyer
[A2].Resize(derlig - 1, 27).ClearContents
' coller resultat
[A2].Resize(UBound(result, 2), UBound(result)) = Application.Transpose(result)
MsgBox Timer - t & " s."
End SubReste 148 lignes, je te laisse le soin de contrôler le résultat. Trop de lignes...
eric
Bonjour,
Je te remercie beaucoup, c'est sublime. Ouf! On constate nettement la différence.
Puis te demander de m'expliquer ces déclarations:
Dim datas As Variant, result() As VariantJ'ai compris que "result" est un tableau mais "datas" représente quoi au juste? Je te remercie beaucoup.
Bonne journée.
Cordialement,
Bonjour,
"datas" représente quoi au juste?
Un tableau également, pour charger toutes les données en mémoire. Mais comme il lit les données sur une feuille il faut le déclarer ainsi.
Par curiosité tu es passé à combien de temps sur ton PC ?
eric
Bonjour,
Je reviens pour donner une autre solution. Etant donné que je voulais renuméroter la colonne 2 et au fil des recherches, j'ai appris qu'il existait cette fonction ou commande "RemoveDuplicates", je ne sais pas comment la qualifier exactement. Alors, l'idée m'est venue d'effacer les valeurs de la colonne 2, de cette façon j'ai pu utiliser RemoveDuplicates, et à la fin renuméroter la colonne 2.
Merci encore une fois Mister Eric, je t'envie un peu pour ta maitrise des tableaux, ton code est génial.
Option Explicit
Sub SupLigneDoublon()
Dim derlig As Long, i As Long, t As Single
t = Timer
With Worksheets("BD")
Application.EnableEvents = False
Application.ScreenUpdating = False
derlig = .Cells(Rows.Count, "A").End(xlUp).Row
.Range("B2:B" & derlig).ClearContents
.Range("A1").CurrentRegion.Range("A1:AA" & derlig).RemoveDuplicates Columns:=Array(1, 2, 3, 4, 5 _
, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16, 17, 18, 19, 20, 21, 22, 23, 24, 25, 26, 27), Header:= _
xlYes
'renuméroter colonne 2
derlig = .Cells(Rows.Count, "A").End(xlUp).Row
For i = 1 To derlig - 1
Cells(i + 1, 2) = i
Next i
End With
MsgBox Timer - t & "s"
End SubBonne journée à tous.
Cordialement,
Beaucoup plus rapide oui.
A noter que ce n'est utilisable qu'à partir d'excel 2007.
eric
Bonjour Eric,
En effet, comme tu l'as souligné mon code ne fonctionne que pour Excel 2007 et +.
Pour le temps d’exécution de ton code, je te dis bravo c'est extraordinaire, sur mon PC je suis passé de près de 7mn à 0,87s.
1000 mercis.
Bonne journée.
Cordialement,