Macro lettrage

[lalala]

Bonjour à tous,

Je me tourne vers vous afin de solliciter votre aide pour la mise en place d'une macro qui pourrait fortement m'aider.

Je vous met un fichier en PJ, afin de vous expliquer ma requête.

Je vous remercie infiniment pour votre aide.

 

[mapomme]

Re : Macro lettrage

Bonjour ROGER2327 ,

Bravo pour ces tests pertinents . Bon, il n'y a pas photo: ratatinée, écrabouillée, explosée, pulvérisée, désagrégée, dynamitée, dispersée, ventilée qu'elle s'est faite mapomme; aux quatre coins de Paris qu'on va la retrouver, éparpillée par petits bouts, façon puzzle (Les Tontons flingueurs - 1963)

 

[ROGER2327]

Re : Macro lettrage

Re...

Bonjour ROGER2327 ,

Bravo pour ces tests pertinents . Bon, il n'y a pas photo: ratatinée, écrabouillée, explosée, pulvérisée, désagrégée, dynamitée, dispersée, ventilée qu'elle s'est faite mapomme; aux quatre coins de Paris qu'on va la retrouver, éparpillée par petits bouts, façon puzzle (Les Tontons flingueurs - 1963)

Regarde la pièce jointe 351985

Yes, Sir ! (Les Tontons flingueurs - 1963)

Reste à élucider pourquoi il y a tant de disparités selon les données à traiter.
Il me semble que ce sont principalement ces lignes​

'...

    If Not dicoTot.exists(key1) Then dicoTot.Add key1, 1 Else dicoTot(key1) = dicoTot(key1) + 1

'...

    If Not dicoDyn.exists(key1) Then dicoDyn.Add key1, 1 Else dicoDyn(key1) = dicoDyn(key1) + 1
    If dicoDyn(key1) <= dicoTot(key2) Then tablo(i, 1) = "À LETTRER" Else tablo(i, 1) = Empty

'...

qui freinent. Mystère de l'objet Scripting.Dictionary...

D'autre part, on peut encore accélérer la procédure associée au bouton Lettrage ROGER2327 (2) tout en simplifiant le code. À voir avec le bouton Lettrage ROGER2327 (21) du classeur joint.​

Bonne journée.


ℝOGER2327
#8158

Lundi 2 Décervelage 143 (Saints Hassassins, praticiens - fête Suprême Quarte)
9 Nivôse An CCXXIV, 6,0495h - salpêtre
2015-W53-3T14:31:08Z

 

[klin89]

Re : Macro lettrage

Bonsoir le forum,

Si j'ai bien compris.
A tester avec le fichier du post 1 :

Option Explicit

Sub test()
Dim a, i As Long, e
    With Sheets("ACTUEL").Cells(1).CurrentRegion
        a = .Value
        ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + 1)
        a(1, 8) = "Lettrage"
        With CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(a, 1)
                If a(i, 6) > 0 Then
                    If Not .exists(a(i, 7)) Then
                        Set .Item(a(i, 7)) = CreateObject("Scripting.Dictionary")
                    End If
                    .Item(a(i, 7))(i) = a(i, 6)
                End If
            Next
            For i = 2 To UBound(a, 1)
                If a(i, 6) < 0 Then
                    If .exists(a(i, 7)) Then
                        For Each e In .Item(a(i, 7)).keys
                            If a(i, 6) + .Item(a(i, 7))(e) = 0 Then
                                a(i, 8) = "A lettrer": a(e, 8) = "A lettrer"
                                .Item(a(i, 7)).Remove e: Exit For
                            End If
                        Next
                    End If
                End If
            Next
        End With
        With .Columns("h").Resize(UBound(a, 1))
            .ClearContents
            .Value = Application.Index(a, 0, 8)
        End With
    End With
End Sub

klin89

 

[ROGER2327]

Re : Macro lettrage

Bonjour à tous.

(...)
A tester avec le fichier du post 1 :
(...)

Avec ce fichier, ça fonctionne.

J'ai fait quelques autres tests avec des petits échantillons de données fournies par les générateurs a, c & d de mon Lien supprimé.

Pour :

• 5 000 lignes : de 0,35 s à 0,82 s ;
• 10 000 lignes : de 0,86 à 3,03 s ;
• 30 000 lignes : de 2,56 s à 23,09 s ;
• 62 500 lignes : de 5,24 s à 106,13 s ;
• 65 535 lignes : de 5,52 s à 116,89 s.

Impossible d'aller plus loin : au-delà de 65 535 lignes, le code plante...
​

Bonne soirée.


ℝOGER2327
#8159

Mardi 3 Décervelage 143 (Astu - Vacuation)
10 Nivôse An CCXXIV, 6,6502h - fléau
2015-W53-4T15:57:38Z

 

[klin89]

Re : Macro lettrage

Bonsoir Roger et bonsoir à tous,

Oui Roger, on y gagnerait en performance avec une liaison anticipée et non une liaison tardive.
j'en connais ici qui saute au plafond avec mes :

With CreateObject("Scripting.Dictionary")
.....
end with

sinon c'est le Application.Index qui plante au delà des 65000 lignes.
On peut le faire comme ça et le retranscrire sur une autre feuille.

Option Explicit

Sub test()
Dim a, i As Long, e
    With Sheets("ACTUEL").Cells(1).CurrentRegion
        a = .Value
        ReDim Preserve a(1 To UBound(a, 1), 1 To UBound(a, 2) + 1)
        a(1, 8) = "Lettrage"
        With CreateObject("Scripting.Dictionary")
            For i = 2 To UBound(a, 1)
                If a(i, 6) > 0 Then
                    If Not .exists(a(i, 7)) Then
                        Set .Item(a(i, 7)) = CreateObject("Scripting.Dictionary")
                    End If
                    .Item(a(i, 7))(i) = a(i, 6)
                End If
            Next
            For i = 2 To UBound(a, 1)
                If a(i, 6) < 0 Then
                    If .exists(a(i, 7)) Then
                        For Each e In .Item(a(i, 7)).keys
                            If a(i, 6) + .Item(a(i, 7))(e) = 0 Then
                                a(i, 8) = "A lettrer": a(e, 8) = "A lettrer"
                                .Item(a(i, 7)).Remove e: Exit For
                            End If
                        Next
                    End If
                End If
            Next
        End With
    End With
    With Sheets("Feuil1")
        .Cells.Clear
        .Cells(1).Resize(UBound(a, 1), UBound(a, 2)).Value = a
    End With
End Sub

Bonne soirée et à l'année prochaine

klin89