Amélioration de l'exécution d'une macro

Version imprimable

2 pièce(s) jointe(s)

Bonjour le forum!

J'ai besoin de vos précieux conseils afin d'augmenter le temps d'exécution de ma macro.

Voici la description: Le fichier possède un onglet qui s'appel "Exportation". Dans cet onglet, je concatène dans une même colonne le contenu de trois colonnes, soit une date, un numéro de route et un numéro de course. Dans la colonne AQ il y a des codes de paiements qui sont inscrits. Il y a une possibilité de 39 codes de paiements différents.
Après avoir concaténer, je colle cette nouvelle colonne dans un autre onglet nommé "Données" puis je supprime les doublons. J'ai donc dans la colonne A de mon onglet "Données" toutes les valeurs unique et dans les cellules G1 à AM1 il y a tous les codes de paiement possibles.
Pour chacune des valeurs unique, je dois savoir combien il y eu de code de paiement.
Voici un exemple de l'onglet "Exportation"
Pièce jointe 596531

Voici ce à quoi doit ressembler l'onglet "Données" au final:
Pièce jointe 596532

Voici le code que j'avais créer au départ:
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 'Pour chaque cellule de la colonne G à AM, Compte le nombre code de paiement 'Défini la colonne dans une variable i = 7 Do While i <= 39 Set c = Sheets("Exportation").Range("AQ2:A" & DernLigne).Find(Range(Split(Columns(i).Address(ColumnAbsolute:=False), ":")(1) & 1).Value, LookIn:=xlValues) If Not c Is Nothing Then For Each cell In Range(Split(Columns(i).Address(ColumnAbsolute:=False), ":")(1) & "2:" & Split(Columns(i).Address(ColumnAbsolute:=False), ":")(1) & DernLigne) MaValeur = Range("A" & cell.Row).Value Range(Split(Columns(i).Address(ColumnAbsolute:=False), ":")(1) & cell.Row).Value = WorksheetFunction.CountIfs(Sheets("Exportation").Columns("A"), MaValeur, Sheets("Exportation").Columns("AQ"), Range(Split(Columns(i).Address(ColumnAbsolute:=False), ":")(1) & "1")) Next End If i = i + 1 Loop
Mais la macro est beaucoup trop longue, j'ai donc fait des recherches et j'ai appris qu'en stockant nos données dans un tableau, la recherche devait être beaucoup plus rapide. Je vais être honnête avec vous, étant néophyte et autodidacte, j'ai trouvé un code sur internet que j'ai copié et essayé d'adapter à mon besoin, mais ça ne fonctionne toujours pas, ma macro est plus longue. J'arrive à mettre mes données dans le tableau mais je ne sais pas comment faire la recherche par la suite. J'utilise encore un for each cell et ce n'est surement pas la bonne méthode.

Voici mon nouveau code :
Code:

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 28 Dim code_paiement As String, numero As Integer, compteur As Integer, ligne As Integer, j As Integer Dim tableau() ReDim tableau(DernLigne - 1, 1) 'Numéro du premier enregistrement dans le tableau numero = 0 'Enregistrement des données dans le tableau For ligne = 2 To DernLigne tableau(numero, 0) = Sheets("Exportation").Range("A" & ligne) 'Mavaleur tableau(numero, 1) = Sheets("Exportation").Range("AQ" & ligne) 'code de paiement numero = numero + 1 Next 'Redéfini la dernière ligne à cause des valeurs unique DernLigne = Range("a" & Rows.Count).End(xlUp).Row 'Défini la colonne - à partir de la colonne G j = 7 'Jusqu'à la colonne AM Do While j <= 39 For Each cell In Range(Split(Columns(j).Address(ColumnAbsolute:=False), ":")(1) & "2:" & Split(Columns(j).Address(ColumnAbsolute:=False), ":")(1) & DernLigne) code_paiement = Range(Split(Columns(j).Address(ColumnAbsolute:=False), ":")(1) & "1").Value compteur = 0 For i = 0 To numero - 1 MaValeur = Range("A" & cell.Row).Value If tableau(i, 0) = MaValeur And tableau(i, 1) = code_paiement Then compteur = compteur + 1 Next Cells(cell.Row, j) = compteur Next j = j + 1 Loop
Voilà, j'espère avoir bien respecter les règles du forum et avoir bien décrit mon problème. Si quelqu'un avait une piste de solution pour moi, ce serait vraiment gentil!

Bonne journée!

Citation:

Envoyé par Pascale B.

Bonjour,

Que donne ce code qui crée un TCD depuis votre onglet Exportation une fois vos doublons supprimés :

Code:

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
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
 
Option Explicit
 
Sub CreationTcdExportation()
 
Dim ShTcd As Worksheet
Dim AireExport As Range
Dim Pvt As PivotTable
Dim I As Integer
 
    For I = Sheets.Count To 1 Step -1
        Application.DisplayAlerts = False
        If Sheets(I).Name = "Données EK" Then Sheets(I).Delete
        Application.DisplayAlerts = True
    Next I
 
    Set AireExport = Sheets("Exportation").UsedRange
    Set ShTcd = Sheets.Add
 
    ActiveWorkbook.PivotCaches.Create(SourceType:=xlDatabase, SourceData:=AireExport).CreatePivotTable _
    TableDestination:=ShTcd.Range("A10"), TableName:="TcdExport"
 
    With ShTcd
        .Name = "Données EK"
        Set Pvt = .PivotTables("TcdExport")
        With Pvt
                With .PivotCache
                    .RefreshOnFileOpen = False
                    .MissingItemsLimit = xlMissingItemsDefault
                End With
                .RepeatAllLabels xlRepeatLabels
                With .PivotFields("Valeur unique")
                    .Orientation = xlRowField
                    .Position = 1
                End With
                .AddDataField .PivotFields("Code de paiement"), "Nombre de Code de paiement", xlCount
                With .PivotFields("Code de paiement")
                    .Orientation = xlColumnField
                    .Position = 1
                End With
                .InGridDropZones = True
                .RowAxisLayout xlTabularRow
 
                With .DataBodyRange
                     .HorizontalAlignment = xlCenter
                     .ColumnWidth = 12
                End With
 
                With .RowRange
                    .HorizontalAlignment = xlCenter
                End With
 
                With .ColumnRange
                    .HorizontalAlignment = xlCenter
                End With
 
 
           End With
    End With
 
End Sub

Pièce jointe 596534

25/04/2021, 13h06
Pascale B.

1 pièce(s) jointe(s)

Bonjour Eric,

Je vous remercie infiniment d'avoir pris le temps de lire ma problématique et d'y avoir apporté une solution.

La seule chose c'est que cette solution m'apporte une autre problématique puisque qu'il y a une suite à ma macro dont je ne vous ai pas parler: À la fin de tous les codes de paiements j'ai d'autres colonnes qui font des calculs sur certaines colonnes précises.

Pièce jointe 596542

Par exemple, la colonne BO additionne les colonnes AC à AF puis BE à BH puis AI et BK. Comme ce ne sont pas tous les même codes de paiement qui sont utilisés à chaque mois et qu'ils ne sont pas tous utilisés en faisant un tableau croisé dynamique, les codes de paiements ne se retrouvent pas tous aux mêmes endroits.

C'est la raison pour laquelle j'utilisais la façon démontré dans mon premier message, mais s'il y avais un moyen dans le tableau croisé dynamique d'indiquer "si le code de paiement = x, y ou z" fait le total dans une colonne, je serais bien ouverte à utiliser cette méthode, seulement mes compétences en programmation ne vont pas jusque là. Si vous pouviez m'indiquer si cela est possible et me donner une piste de recherche, je tenterais volontiers d'utiliser cette option.

Merci beaucoup!

Citation:

Envoyé par Pascale B.

Si votre tableau Données est "bourré" de formules, regardez le temps gagné en neutralisant le calcul automatique et en empêchant la mise à jour de l'écran dans votre programme actuel.
Le code ci-dessous permet également de calculer le temps de traitement.
Code:

1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 Dim HeureDebut, HeureFin, TempsTotal HeureDebut = Timer With Application .ScreenUpdating = False .Calculation = xlCalculationManual End With ' Suite du programme ' ... With Application .ScreenUpdating = True .Calculation = xlCalculationAutomatic End With HeureFin = Timer TempsTotal = HeureFin - HeureDebut MsgBox "Temps total du traitement : " & Round(TempsTotal, 0) & " seconde(s)"

26/04/2021, 13h37
Pascale B.

Bonjour Eric,

Encore une fois merci d'avoir pris le temps, c'est très apprécié! Ma ma macro est maintenant beaucoup plus rapide!

Bonne journée!