Fichier Excel macro de plus en plus lent

Le 13/11/2017 à 23:41

Pour Brutus, je veux bien te croire ... et pourtant, dans la BD d'Astérix, César s'adresse parfois à Brutus en lui disant :

« Toi aussi, mon fils » (exemple avec la 1ère image ci-dessous) ; ton jeu d'échecs avec plateau en triangle me fait

beaucoup penser au jeu bizingo, mais les règles sont sûrement différentes ! (voir la 2ème image).

screen 2 screen 1
Le 14/11/2017 à 09:59

Hello Curulis,

J'ai testé ta nouvelle formule sur VO SUD, j'ai un message d'erreur (voir en PJ)

Concernant le transfert de STOCK => AFFECTATION, j'en suis a 64 sec pour 11 lignes

Concernant le transfert de AFFECTATION => répartition, idem 66 sec pour les 11 mêmes lignes.

Est-il possible de valider les transferts des affectations par double clic au lieu que ce soit automatique?

Après réflexion, il n'est pas nécessaire de garder les couleurs lors des transferts lors de la réparation des véhicules après les affectations, quelque soit la couleur (EST, NORD, CARGO, etc...), on peut donc simplifier au niveau des traitements.

A+

capture
Le 14/11/2017 à 11:02

Salut Nico,

Tu n'avais pas de transfert vers 'VOM' sans doute... dans une feuille où 'VOM' reste le plus probable...

Et comme ceci?

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tDataO, tDataN(), tDataVOM(), tDataEST()
'
Cancel = True
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("L:L")) Is Nothing Then
    iRow = Range("A" & Rows.Count).End(xlUp).Row
    tDataO = Range("A2:Q" & iRow).Value
    For x = 1 To UBound(tDataO, 1)
        If tDataO(x, 13) <> "" Then
            Select Case tDataO(x, 13)
                Case "VOM"
                    iIdxVOM = iIdxVOM + 1
                    ReDim Preserve tDataVOM(17, iIdxVOM)
                    For z = 1 To 17
                        tDataVOM(z - 1, iIdxVOM - 1) = tDataO(x, z)
                    Next
                Case "EST"
                    iIdxEST = iIdxEST + 1
                    ReDim Preserve tDataEST(17, iIdxEST)
                    For z = 1 To 17
                        tDataEST(z - 1, iIdxEST - 1) = tDataO(x, z)
                    Next
                Case Else
                    iIdxNEW = iIdxNEW + 1
                    ReDim Preserve tDataN(17, iIdxNEW)
                    For z = 1 To 17
                        tDataN(z - 1, iIdxNEW - 1) = tDataO(x, z)
                    Next
            End Select
        End If
    Next
    For x = 1 To 2
        If IIf(x = 1, iIdxVOM > 1, iIdxEST > 1) Then
            sData = IIf(x = 1, "VOM", "VO EST")
            iRowT = Worksheets(sData).Range("A" & Rows.Count).End(xlUp).Row + 1
            Worksheets(sData).Range("A" & iRowT).Resize(IIf(x = 1, UBound(tDataVOM, 2), UBound(tDataEST, 2)), 17) = WorksheetFunction.Transpose(IIf(x = 1, tDataVOM, tDataEST))
        End If
    Next
    Range("A2:Q" & iRow + 1).ClearContents
    Range("A2").Resize(UBound(tDataN, 2), 17) = WorksheetFunction.Transpose(tDataN)
End If
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End Sub

A+

Le 14/11/2017 à 12:23

Alors quand je clic 2 fois sur L:L, le transfert ne s'effectue pas, par contre et je n'ai pas de message d'erreur. J'ai le format de la date des colonnes A et N qui change, le jour et le mois s'inverse...

Le 14/11/2017 à 13:47

Salut Nico,

ici, le transfert s'effectue depuis la première version sans souci...

Pour le reste, j'ai mis toutes les précautions nécessaires et, la totale, je formate à chaque transfert, les colonnes dates en [A:A] et [N:N] dans chaque feuille.

Range("N2:N" & iRow).NumberFormat = "mm/dd/yyyy"

Ici, je répète, en travaillant sur le fichier que tu m'as envoyé, je n'ai plus l'ombre d'un souci.

La macro traite 10.000 lignes en 2,7 secondes, transferts et tout et tout...

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tDataO, tDataN(), tDataVOM(), tDataEST()
'
Cancel = True
'
ReDim Preserve tDataVOM(17, 1)
ReDim Preserve tDataEST(17, 1)

Application.EnableEvents = False
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("L:L")) Is Nothing Then
    iRow = Range("A" & Rows.Count).End(xlUp).Row
    tDataO = Range("A2:Q" & iRow).Value
    For x = 1 To UBound(tDataO, 1)
        If tDataO(x, 13) <> "" Then
            Select Case tDataO(x, 13)
                Case "VOM"
                    iIdxVOM = iIdxVOM + 1
                    ReDim Preserve tDataVOM(17, iIdxVOM)
                    For z = 1 To 17
                        tDataVOM(z - 1, iIdxVOM - 1) = tDataO(x, z)
                    Next
                Case "EST"
                    iIdxEST = iIdxEST + 1
                    ReDim Preserve tDataEST(17, iIdxEST)
                    For z = 1 To 17
                        tDataEST(z - 1, iIdxEST - 1) = tDataO(x, z)
                    Next
                Case Else
                    iIdxNEW = iIdxNEW + 1
                    ReDim Preserve tDataN(17, iIdxNEW)
                    For z = 1 To 17
                        tDataN(z - 1, iIdxNEW - 1) = tDataO(x, z)
                    Next
            End Select
        End If
    Next
    For x = 1 To 2
        If IIf(x = 1, iIdxVOM > 1, iIdxEST > 1) Then
            sData = IIf(x = 1, "VOM", "VO EST")
            With Worksheets(sData)
                iRowT = .Range("A" & Rows.Count).End(xlUp).Row + 1
                .Range("A" & iRowT).Resize(IIf(x = 1, UBound(tDataVOM, 2), UBound(tDataEST, 2)), 17) = WorksheetFunction.Transpose(IIf(x = 1, tDataVOM, tDataEST))
                iRowT = .Range("A" & Rows.Count).End(xlUp).Row + 1
                .Range("A2:A" & iRowT).NumberFormat = "mm/dd/yyyy"
                .Range("N2:N" & iRowT).NumberFormat = "mm/dd/yyyy"
            End With
        End If
    Next
    If iIdxNEW > 0 Then
        Range("A2:Q" & iRow + 1).ClearContents
        Range("A2").Resize(UBound(tDataN, 2), 17) = WorksheetFunction.Transpose(tDataN)
        iRow = Range("A" & Rows.Count).End(xlUp).Row + 1
        Range("A2:A" & iRow).NumberFormat = "mm/dd/yyyy"
        Range("N2:N" & iRow).NumberFormat = "mm/dd/yyyy"
    End If
End If
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End Sub

A+

Le 14/11/2017 à 14:42

Je n'y comprends plus rien, j'ai pourtant bien suivi a la lettre ce que tu m'as dit de faire.

As-tu la possibilité de m'envoyer ton fichier modifié et fonctionnel afin que je puisse faire une comparaison avec ce que j'ai fait, je voudrais bien comprendre où Est-ce que j'ai fait la ou les boulettes.

Le 14/11/2017 à 15:47

Salut Nico,

voilà ton fichier, prêt à double-cliquer, je précise, en feuille 'VO SUD", colonne [L:L] !

  • cette feuille est gonflée à 10.000 lignes ;
  • les lignes sélectionnées "VOM" ou "EST" sont "marquées" en [J:J] pour bien les repérer ;
  • les dernières lignes en 'VOM' et 'VO EST' avant transfert sont marquées de couleur orange.

En [M:M], tu as deux façons pour préciser l'affectation des lignes (pas de liste de validation) :

  • un clic : la ligne bascule, dans l'ordre de SUD --> VOM --> EST --> retour à SUD
  • en sélectionnant plusieurs cellules de la colonne : même séquence de changement pour la sélection selon la valeur de la première cellule.

A te lire,

Tu peux déjà changer, dans 'VO SUD', la macro suivante... 

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
Application.ScreenUpdating = False
Application.EnableEvents = False
'
If Target.Column = 13 Then
    sData = IIf(Cells(Target.Row, 13) <> "SUD", IIf(Cells(Target.Row, 13) = "VOM", "EST", "SUD"), "VOM")
    If Target.Count = 1 Then
        Target = sData
    Else
        Range("M" & Target.Row & ":M" & (Target.Rows.Count + Target.Row) - 1).Value = sData
    End If
    Cells(Target.Row, 12).Select
End If
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End Sub
Le 14/11/2017 à 16:29

WOuahou !!

J'avais pas du tout cru possible de faire ce genre de programmation en faisant simplement des clics sur une cellule ! Trop classe !

Concernant la feuille AFFECTATION, tu travailles sur une validation par double clic pour les transferts?

Le 14/11/2017 à 16:55

Salut Nico,

ça fonctionne donc?

Pour 'AFFECTATION' avec double-clic, c'est fait, oui, et je pense à d'autres trucs mais avant de faire des choses inutiles, ton avis, stp!

Dans 'STOCK', serait-il intéressant pour toi de pouvoir envoyer à ton CVVO des demandes ciblées de ce dernier?

Par exemple, s'il te demande les CLIO3 ou SCENIC ou les voitures de OVERLEASE ou les CARGO, marquées AFFECTATION ou TRANSPORT, cela te serait-il utile de pouvoir le faire d'un double-clic? Cela se fait-il, même?

A+

Le 14/11/2017 à 17:22

Oui avec ton fichier, nickel, je vais regarder chez moi ce soir ce que j'ai mal fait.

Concernant le double clic en AFFECTATION, ca serait super, j'ai un message d'erreur sur le fichier envoyé.

Concernant mon CVVO, non il n'a pas de demande particulière. Généralement je fais des recherches par contrôle + F.

A+

capture
Le 15/11/2017 à 00:20

Salut Nico,

voici la macro à coller dans le module de la feuille 'AFFECTATION' en remplacement de ce qui existe déjà.

Démarrage de la macro par un double-clic en colonne [M:M] .

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData, tDataNEW(), tDataVOM(), tDataSOCCO(), tDataNORD(), tDataSUD(), tDataEST(), tDataRILLIEUX()
'
Cancel = True
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
If Not Intersect(Target, Range("M:M")) Is Nothing Then
    iRow = Range("A" & Rows.Count).End(xlUp).Row
    tData = Range("A2:Q" & iRow).Value
    For x = 1 To UBound(tData, 1)
        If tData(x, 12) <> "" Then
            Select Case tData(x, 13)
                Case "VOM"
                    iIdxVOM = iIdxVOM + 1
                    ReDim Preserve tDataVOM(17, iIdxVOM)
                    For z = 1 To 17
                        tDataVOM(z - 1, iIdxVOM - 1) = tData(x, z)
                    Next
                Case "SOCCO"
                    iIdxSOCCO = iIdxSOCCO + 1
                    ReDim Preserve tDataSOCCO(17, iIdxSOCCO)
                    For z = 1 To 17
                        tDataSOCCO(z - 1, iIdxSOCCO - 1) = tData(x, z)
                    Next
                Case "NORD"
                    iIdxNORD = iIdxNORD + 1
                    ReDim Preserve tDataNORD(17, iIdxNORD)
                    For z = 1 To 17
                        tDataNORD(z - 1, iIdxNORD - 1) = tData(x, z)
                    Next
                Case "SUD"
                    iIdxSUD = iIdxSUD + 1
                    ReDim Preserve tDataSUD(17, iIdxSUD)
                    For z = 1 To 17
                        tDataSUD(z - 1, iIdxSUD - 1) = tData(x, z)
                    Next
                Case "EST"
                    iIdxEST = iIdxEST + 1
                    ReDim Preserve tDataEST(17, iIdxEST)
                    For z = 1 To 17
                        tDataEST(z - 1, iIdxEST - 1) = tData(x, z)
                    Next
                Case "RILLIEUX"
                    iIdxRILLIEUX = iIdxRILLIEUX + 1
                    ReDim Preserve tDataRILLIEUX(17, iIdxRILLIEUX)
                    For z = 1 To 17
                        tDataRILLIEUX(z - 1, iIdxRILLIEUX - 1) = tData(x, z)
                    Next
                Case Else
                    iIdxNEW = iIdxNEW + 1
                    ReDim Preserve tDataNEW(17, iIdxNEW)
                    For z = 1 To 17
                        tDataNEW(z - 1, iIdxNEW - 1) = tData(x, z)
                    Next
            End Select
        End If
    Next
    For x = 1 To 7
        sData = Choose(x, "VOM", "SOCCO", "VO NORD", "VO SUD", "VO EST", "VO RILLIEUX", "AFFECTATION")
        If Choose(x, iIdxVOM > 0, iIdxSOCCO > 0, iIdxNORD > 0, iIdxSUD > 0, iIdxEST > 0, iIdxRILLIEUX > 0, iIdxNEW > 0) Then
            iRowT = Worksheets(sData).Range("A" & Rows.Count).End(xlUp).Row + 1
            If x = 7 Then
                Range("A2:Q" & iRowT).Delete
                iRowT = 2
            End If
            Worksheets(sData).Range("A" & iRowT) _
                .Resize(Choose(x, iIdxVOM, iIdxSOCCO, iIdxNORD, iIdxSUD, iIdxEST, iIdxRILLIEUX, iIdxNEW), 17) _
                = WorksheetFunction.Transpose(Choose(x, tDataVOM, tDataSOCCO, tDataNORD, tDataSUD, tDataEST, tDataRILLIEUX, tDataNEW))
        End If
    Next
End If
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End Sub

Petit à petit...

A+

Le 15/11/2017 à 09:03

Salut Nico,

j'essaie un truc mais quelque chose me dit que j'aurais besoin de voir ce qui a dans ta feuille 'Listes'...

On y accède comment?

Ne loupe pas le post précédent... Celui-ci n'est pas le dernier...

A+

Le 15/11/2017 à 14:43

Hello,

Ca ne marche pas

Le 15/11/2017 à 14:51

M'enfin, ce n'est pas possible!

J'ai ton fichier et ça roule du tonnerre, ici!

Envoie-moi le fichier sur lequel tu travailles et, tant qu'à faire, débloque-moi ta feuille 'Listes', stp.

Si c'est secret, envoie-moi tout ça en MP...

A+

Le 15/11/2017 à 15:27

Rien a cacher , la feuille est simplement masquée.

Je t'envoie le lien du fichier :

https://www.cjoint.com/c/GKpozhIqf7S

C'est celui que tu m'as transmis et pour lequel j'ai simplement supprimé ce qu'il y avait en AFFECTATION comme tu' mas demandé et collé ce que tu m'as transmis . je ne comprends pas pourquoi ca ne fonctionne pas chez moi

Le 15/11/2017 à 15:55

Compris!

Je reviens très vite!

A+

Le 15/11/2017 à 16:12

Voilà!

Private Sub Worksheet_BeforeDoubleClick(ByVal Target As Range, Cancel As Boolean)
'
Dim tData, tDataNEW(), tDataVOM(), tDataSOCCO(), tDataNORD(), tDataSUD(), tDataEST(), tDataRILLIEUX()
'
Cancel = True
'
Application.EnableEvents = False
Application.ScreenUpdating = False
'
ReDim Preserve tDataNEW(17, 1)
'
If Not Intersect(Target, Range("M:M")) Is Nothing Then
    iRow = Range("A" & Rows.Count).End(xlUp).Row
    tData = Range("A2:Q" & iRow).Value
    For x = 1 To UBound(tData, 1)
        If tData(x, 12) <> "" Then
            Select Case tData(x, 13)
                Case "VOM"
                    iIdxVOM = iIdxVOM + 1
                    ReDim Preserve tDataVOM(17, iIdxVOM)
                    For z = 1 To 17
                        tDataVOM(z - 1, iIdxVOM - 1) = tData(x, z)
                    Next
                Case "SOCCO"
                    iIdxSOCCO = iIdxSOCCO + 1
                    ReDim Preserve tDataSOCCO(17, iIdxSOCCO)
                    For z = 1 To 17
                        tDataSOCCO(z - 1, iIdxSOCCO - 1) = tData(x, z)
                    Next
                Case "NORD"
                    iIdxNORD = iIdxNORD + 1
                    ReDim Preserve tDataNORD(17, iIdxNORD)
                    For z = 1 To 17
                        tDataNORD(z - 1, iIdxNORD - 1) = tData(x, z)
                    Next
                Case "SUD"
                    iIdxSUD = iIdxSUD + 1
                    ReDim Preserve tDataSUD(17, iIdxSUD)
                    For z = 1 To 17
                        tDataSUD(z - 1, iIdxSUD - 1) = tData(x, z)
                    Next
                Case "EST"
                    iIdxEST = iIdxEST + 1
                    ReDim Preserve tDataEST(17, iIdxEST)
                    For z = 1 To 17
                        tDataEST(z - 1, iIdxEST - 1) = tData(x, z)
                    Next
                Case "RILLIEUX"
                    iIdxRILLIEUX = iIdxRILLIEUX + 1
                    ReDim Preserve tDataRILLIEUX(17, iIdxRILLIEUX)
                    For z = 1 To 17
                        tDataRILLIEUX(z - 1, iIdxRILLIEUX - 1) = tData(x, z)
                    Next
                Case Else
                    iIdxNEW = iIdxNEW + 1
                    ReDim Preserve tDataNEW(17, iIdxNEW)
                    For z = 1 To 17
                        tDataNEW(z - 1, iIdxNEW - 1) = tData(x, z)
                    Next
            End Select
        End If
    Next
    For x = 1 To 7
        sData = Choose(x, "VOM", "SOCCO", "VO NORD", "VO SUD", "VO EST", "VO RILLIEUX", "AFFECTATION")
        If Choose(x, iIdxVOM > 0, iIdxSOCCO > 0, iIdxNORD > 0, iIdxSUD > 0, iIdxEST > 0, iIdxRILLIEUX > 0, iIdxNEW >= 0) Then
            iRowT = Worksheets(sData).Range("A" & Rows.Count).End(xlUp).Row + 1
            If x = 7 Then
                Range("A2:Q" & iRowT).Delete
                iRowT = 2
            End If
            Worksheets(sData).Range("A" & iRowT) _
                .Resize(Choose(x, iIdxVOM, iIdxSOCCO, iIdxNORD, iIdxSUD, iIdxEST, iIdxRILLIEUX, IIf(iIdxNEW = 0, 1, iIdxNEW)), 17) _
                = WorksheetFunction.Transpose(Choose(x, tDataVOM, tDataSOCCO, tDataNORD, tDataSUD, tDataEST, tDataRILLIEUX, tDataNEW))
        End If
    Next
End If
'
Application.ScreenUpdating = True
Application.EnableEvents = True
'
End Sub

A tout à l'heure!

Le 15/11/2017 à 16:26

Magnifique !!!

Que du bonheur !

Le 15/11/2017 à 16:47

Bon, autres choses :

Dates

- Y a-t-il des circonstances où il est possible d'afficher la date du jour (histoire que tu n'aies pas à le faire manuellement ) ?

° dans quelles feuilles ?

° lors d'un simple clic, ou une création de ligne ('STOCK'), dans quelle(s) colonne(s) ?

° lors d'un transfert (double-clic), dans quelle(s) colonne(s) ?

Options

Je te prépare quelque chose que, perso, j'adore : une TEXTBOX qui s'affiche dans les cellules où tu dois faire un choix d'options.

En tapant, une recherche se fera en 'Listes' (tu vois pourquoi il me la fallait!) et préremplira la TEXTBOX en fonction des lettres tapées.

Si rien n'est trouvé, cela sera considéré comme nouvelle donnée (loueur, client, véhicule...), enregistrée et triée dans 'Listes'.

Donc, tu me fournis ces options pour chaque colonne de chaque feuille, à mon avis, uniquement 'STOCK', peut-être 'AFFECTATION', que je prépare tout ça.

Si tu as une bonne idée qui te faciliterait la vie, n'hésite pas tant que je suis chaud!

A+

Le 15/11/2017 à 17:22

Tu en a des ces idées !!!

Les dates:

Oui, on peut noter les dates en automatique lors des transferts des AFFECTATIONS => SUD / VOM / SOCCO / EST / NORD / RILLIEUX sur les colonnes dédiées :

P:P => VOM / SOCCO

N:N => VO des 4 ETS

Mais pas les TRANSPORTS qui dépendent de la date de saisie du jour J.

Lors d 'une création de ligne non plus, car mon problème c'est que les saisies ne se font pas forcement le jour de l'expertise et que la date d'expertise est très importante pour la valorisation des frais.

Le Textbox, je suis fan !

Des idées, je vais y réfléchir, et j'en ai déjà une

Est-t-il possible d'intégrer pour les loueurs (je peux te donner une liste), en STOCK, le calcul automatique de la date de facturation des frais de stockage en tenant compte d'un délai de 15 jours calendaires, et d'intégrer cette date en colonne F:F et le montant HT a facturer en colonne E:E (15.00€ / jours que je puisse facilement modifier). En sachant que la date de de frais ne peut pas tomber sur un jour de weekend ou jour férié.

Exemple 1: Expertise le 26/10/2017 => Frais le 10/11/2017 ( 5x 15.00€) = 75.00€

Exemple 2: Expertise le 15/11/2017 => Frais le 30/11/2017 = 0.00€

A+

Rechercher des sujets similaires à "fichier macro lent"