Optimisation macro

Bonjour ,

J'ai une fonction qui supprime les doublons les plus anciens (situés plus en haut) et qui concatène leurs données . Il fonctionne très bien mais je voudrais qu'il s'éxecute beaucoup plus rapidement car j'applique cette fonction sur plus de 10 000 lignes. Est ce possible d'arranger le code ou existe-il des astuces? J'ai déja essayé avec Application.screenUpdating mais cela ne donne rien.

Voici mon code :

Cells(derniere_ligne, colonne).Select

For i = ActiveCell.Row To 1 Step -1

contenu = Cells(i, colonne).Value

For e = i - 1 To 1 Step -1

If Cells(e, colonne) = contenu Then

For y = 2 To Cells(e, colonne).SpecialCells(xlCellTypeLastCell).Column

'concatène les 2 lignes

If Cells(e, y) <> "" And Cells(i, y) = "" Then

Cells(i, y) = Cells(e, y)

End If

Next y

Rows(e).Delete

End If

Next e

Next i

Merci d'avance.

Bonjour

Le plus simple c'est de fournir un fichier test (avec des données non traitées ) ainsi que ta macro pour que l'on sache quel résultat tu dois obtenir

Voici un fichier exemple où l'identifiant est l' "ID". Si un même ID est rentré alors la valeur la plus ancienne sera suprimé (la plus en haut) et si une information manque elle sera concatenée.

Sur cette exemple c'est très rapide mais sur 10 000 ligne le calcul s'avère très long. Que faut-il faire?

Bonjour,

Une possibilité :

Sub doublon_G()
For iC = 1 To 10
   If Cells(1, iC) = "id" Then Exit For
Next iC
iLR = Cells(Rows.Count, iC).End(3).Row
iLC = Cells(1, Columns.Count).End(1).Column
tablo = Range(Cells(1, 1), Cells(iLR, iLC))
For i = iLR To 3 Step -1
   For ii = i - 1 To 2 Step -1
      If tablo(ii, iC) = tablo(i, iC) Then
         For k = 1 To iLC
          If tablo(ii, k) <> "" And tablo(i, k) = "" Then
            tablo(i, k) = tablo(ii, k)
          End If
            tablo(ii, k) = ""
         Next
      End If
   Next
Next
Range(Cells(1, 1), Cells(iLR, iLC)) = tablo
For i = iLR To 2 Step -1
If Cells(i, iC) = "" Then Rows(i).Delete
Next
End Sub

A+

Le calcul s'effectue en 20 sec contre 10 min pour l'ancien. Merci beaucoup.

Un petit coup de ScreenUpdating au début et on gagne encore quelques secondes...

Sub doublon_G()
Application.ScreenUpdating = False
'lasuite sans changement...

A+

Bonjour

Comme j'ai cherché un peu

La solution ressemble un peu à celle de Galopin01

Je m'embête un peu plus (à tord surement)

Bonjour,

Ma petite contribution.

Option Explicit
Private Sub cmdSD_Click()

Dim derLigne As Long
Dim i As Long
Dim a As Byte

    Application.ScreenUpdating = False
    derLigne = Range("A" & Rows.Count).End(xlUp).Row

    For i = 2 To derLigne
        a = Application.WorksheetFunction.CountIf(Range(Cells(i, 1), Cells(derLigne, 1)), Cells(i, 1))
        If a > 1 Then Rows(i).Delete xlUp
    Next i

End Sub

Merci pour votre aide. Mais seul la solution de Galopin01 me permet de supprimer les doublons en gardant l'ordre de base tout en concaténant les nouvelles et les anciennes données.

Encore merci.