Rassembler données de doublons multi critéres (Expert VBA requis)

Résolu/Fermé
Akatsucki Messages postés 91 Date d'inscription jeudi 1 octobre 2020 Statut Membre Dernière intervention 16 décembre 2021 - 17 avril 2021 à 14:24
Akatsucki Messages postés 91 Date d'inscription jeudi 1 octobre 2020 Statut Membre Dernière intervention 16 décembre 2021 - 17 avril 2021 à 22:35
Bonjours j’aimerais augmenter la vitesse du regroupement des doublons dans ce fichier qui prends beaucoup de temps, j'ai pensé à utilisé la methode du dictionnaire mais je ne sais pas par ou commencer car il y a plusieurs condition

'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
                                'POINT A AMELIORER
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX

If True Then

'Suppression des doublons
    CurrentRow = iStartRow
    bSautPageDone = False
    Go = True
    Do While (CurrentRow < iLastRow And Go)
            
        s24hInit = Cells(CurrentRow, sPosteCol).Value
        sMouleInit = Cells(CurrentRow, SMouleCol).Value
        sProgInit = Cells(CurrentRow, sProgrammePostCol).Value
        
        sCodeTissu = Cells(CurrentRow, sTissuCol - 2).Value
        sLargeur = Cells(CurrentRow, sLargeurCol).Value
        
        sMachine = Cells(CurrentRow, sMachine1Col).Value
        
'Saut de page pour les Qt a 0
        If (Cells(CurrentRow, sProgrammePostCol) = 0 And Not bSautPageDone) Then
            iSautPageNum = CurrentRow
            bSautPageDone = True
            'SautPage
        End If
        
'Mise en forme du premier champ de commentaire si ligne non vide
        If (sCodeTissu <> "" Or sLargeur <> "" Or sMachine <> "") Then
            Cells(CurrentRow, sCommConfCol).Value = "'" & Cells(CurrentRow, sRolCol + 1).Value & " " & Cells(CurrentRow, sCommConfCol).Value & " "
        Else
            Go = False
        End If
        
    Workrow = CurrentRow + 1

    sCodeTissu1 = Cells(Workrow, sTissuCol - 2).Value
    sLargeur1 = Cells(Workrow, sLargeurCol).Value
    sMachine1 = Cells(Workrow, sMachine1Col).Value
        
    Dim sIsMultiPlis As Boolean
    sIsMultiPlis = Cells(Workrow, 1).Value <> ""
                      
    While (sCodeTissu = sCodeTissu1 And sLargeur = sLargeur1 And sMachine = sMachine1 And (sCodeTissu <> "" Or sLargeur <> "" Or sMachine <> "") And Not sIsMultiPlis)
    'rolhing + commentaire
    Cells(CurrentRow, sCommConfCol).Value = Cells(CurrentRow, sCommConfCol).Value & Cells(Workrow, sCommConfCol).Value & " "

    'Copy des quantités
    Range(Cells(Workrow, 23), Cells(Workrow, 34)).Copy
    Range(Cells(Workrow, 23), Cells(Workrow, 34)).Offset(-1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
        :=False, Transpose:=False
                
    Range(Cells(Workrow, 16), Cells(Workrow, 19)).Copy
    Range(Cells(Workrow, 16), Cells(Workrow, 19)).Offset(-1, 0).PasteSpecial Paste:=xlPasteValues, Operation:=xlAdd, SkipBlanks _
        :=False, Transpose:=False
                      
'Suppression de la ligne
    Cells(Workrow, 1).EntireRow.Delete Shift:=xlUp
                        
'Mise a jour des valeur pour l'iteration suivante
    sCodeTissu1 = Cells(Workrow, sTissuCol - 2).Value
    sLargeur1 = Cells(Workrow, sLargeurCol).Value
    sMachine1 = Cells(Workrow, sMachine1Col).Value
    
    Wend
        
'Division en nombre de K7
     Cells(CurrentRow, 19).Select
        If Cells(CurrentRow, 7).Value = "KM" Then
            ActiveCell.Value = ActiveCell.Value / smetrageK7KM
        Else
            ActiveCell.Value = ActiveCell.Value / smetrageK7EST
        End If
        
        CurrentRow = CurrentRow + 1
    Loop
    
End If


'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX
'XXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXXX


je vous joint mon fichier pour plus de détail
https://cjoint.com/c/KDrmv7yK2hm
A voir également:

1 réponse

yg_be Messages postés 20759 Date d'inscription lundi 9 juin 2008 Statut Contributeur Dernière intervention 4 décembre 2022 1 272
17 avril 2021 à 21:57
bonjour,
l'indentation défectueuse de ton code le rend peu lisible.
j'y vois deux boucles imbriquées.
est-ce cela qui le rend lent? as-tu pu identifier où le code perdait du temps?
peux-tu donner des informations factuelles à propos du temps que cela prend?

il serait sans doute utile que tu décrives ce que tu veux obtenir et comment u le fais, plutôt que nous laisser le deviner en analysant ton code.
entre humains, il est plus efficace d'utiliser une langue telle que le français.
de plus, ton code est peut-être incorrect ou inefficace.

au hasard:
il est parfois utile d'utiliser les tableaux pour accélérer l'accs aux données.
il est parfois utile de trier les données pour accélérer la détection de doublons.
0
Akatsucki Messages postés 91 Date d'inscription jeudi 1 octobre 2020 Statut Membre Dernière intervention 16 décembre 2021
17 avril 2021 à 22:35
Bonsoir,
Merci de ta réponse, je sais que je n’est pas donné énormément d’informations sur ce que je désire réellement... je m’explique :

Le tableau est trié dès lors que la macro ci dessus commence, elle dois récupérer les donnée de certaine cellules et les additionner a la colonne supérieure pour garder une et une seule ligne sur les doublons possible
Les doublons sont cherchés d’après plusieurs critères ( code,tissu,largeur et machine)

En gros si à la ligne 6 et à la ligne 7 ces conditions sont respectées, on additionne les cellules désiré puis on supprime la ligne qu’on a récupèré... puis on continue la boucle pour voir si la ligne suivante a les mêmes conditions pour encore additionner et ainsi de suite jusqu’à regrouper toutes les cellules ensemble

Je sais pas si je suis assez clair, à vous de me dire

La macro met environ 2min à ce réaliser mais ceci n’est qu’une partie de l’ensemble des étapes à faire (encore 5 fois la même macro sur d’autre produit qui rallonge la macro à 10min environ)

Pour infos ce n’est pas une macro de moi, donc j’aimerais gagner du temps car c’est à cet endroit que ça prend le plus de temps (entre 60 et 80secondes)

Cordialement
0