Augmenter la rapidité de la macro

Le 08/06/2021 à 14:30

Bonjour

J'ai une macro qui permet de récupérer des données de toutes les classeurs présentes dans le même dossier où est présent le classeur d'origine, sans ouvrir les classeurs.. Les données s'additionnes tous dans le classeur d'origine.

La macro tourne bien mais est très longue étant données le nombre de classeurs présent et le nombre de données à coller.

Je sais qu'il a moyen de modifier mon Array pour rapetisser le code. (Je suis preneur de la modification).

Voici mon code. Je vous laisse voir s'il est possible de la modifier pour aider à la rendre plus rapide.

Sub SommeCellules()
    Dim Chemin As String, Fichier As String, Feuille As String, Somme(), Cellules, i As Byte, V As String, AddCel

Application.Cursor = xlWait 'affiche le sablier
patience.Show vbModeless 'affiche l'userform nommé "patience"
patience.Repaint 'rafraichit le contenu à placer
'commence le traitement

    Chemin = ThisWorkbook.Path & "\"

    Feuille = "Sommaire": Cellules = Array("A9", "B9", "C9", "D9", "E9", "F9", "G9", "H9", "I9", "J9", "K9", "L9", "M9", "N9", _
    "A11", "B11", "C11", "D11", "E11", "F11", "G11", "H11", "I11", "J11", "K11", "L11", "M11", "N11", _
    "A16", "B16", "C16", "D16", "E16", "F16", "G16", "H16", "I16", "J16", "K16", "L16", "M16", "N16", _
    "A18", "B18", "C18", "D18", "E18", "F18", "G18", "H18", "I18", "J18", "K18", "L18", "M18", "N18", _
    "A23", "B23", "C23", "D23", "E23", "F23", "G23", "H23", "I23", "J23", "K23", "L23", "M23", "N23", _
    "A25", "B25", "C25", "D25", "E25", "F25", "G25", "H25", "I25", "J25", "K25", "L25", "M25", "N25", _
    "A30", "B30", "C30", "D30", "E30", "F30", "G30", "H30", "I30", "J30", "K30", "L30", "M30", "N30", _
    "A32", "B32", "C32", "D32", "E32", "F32", "G32", "H32", "I32", "J32", "K32", "L32", "M32", "N32", _
    "A37", "B37", "C37", "D37", "E37", "F37", "G37", "H37", "I37", "J37", "K37", "L37", "M37", "N37", _
    "A39", "B39", "C39", "D39", "E39", "F39", "G39", "H39", "I39", "J39", "K39", "L39", "M39", "N39", _
    "A44", "B44", "C44", "D44", "E44", "F44", "G44", "H44", "I44", "J44", "K44", "L44", "M44", "N44", _
    "A46", "B46", "C46", "D46", "E46", "F46", "G46", "H46", "I46", "J46", "K46", "L46", "M46", "N46", _
    "A51", "B51", "C51", "D51", "E51", "F51", "G51", "H51", "I51", "J51", "K51", "L51", "M51", "N51", _
    "A53", "B53", "C53", "D53", "E53", "F53", "G53", "H53", "I53", "J53", "K53", "L53", "M53", "N53")
    ReDim Somme(LBound(Cellules) To UBound(Cellules))
     For i = LBound(Cellules) To UBound(Cellules): Somme(i) = CDbl(Application.Sum(Range(Cellules(i)))): Next
   Fichier = Dir(Chemin & "*.xlsm")

    Do While Len(Fichier) > 0
                For i = LBound(Cellules) To UBound(Cellules)
                    V = "'" & Chemin & "[" & Fichier & "]" & Feuille & "'!" & Range(Cellules(i)).Address(, , xlR1C1)
                    AddCel = Application.ExecuteExcel4Macro(V)
                    Somme(i) = CDbl(Somme(i)) + CDbl(AddCel)
                Next
        Fichier = Dir()
    Loop
    For i = LBound(Somme) To UBound(Somme): Range(Cellules(i)) = Somme(i): Next

    Unload patience 'décharge l'userform de la mémoire
Application.Cursor = xlDefault 'remet le curseur par défault

End Sub

Merci de votre aide

Le 08/06/2021 à 14:59

Bonjour,

Je n'ai pas toute la solution, mais déjà, pour la première somme, tu peux définir une plage, et faire l'addition sans boucle comme ceci :

Sub essai()
Dim Plg As Range
Set Plg = Range("A9:N9,A11:N11,A16:N16,A18:N18,A23:N23,A25:N25,A30:N30,A32:N32,A37:N37,A39:N39,A44:N44,A46:N46,A51:N51,A53:N53")
x = Application.Sum(Plg)
End Sub

ça pourrait donner des idées...

Le 08/06/2021 à 16:49

Re-,

J'ai fait un essai, en utilisant l'ADO (je rapatrie en une seule fois le tableau du fichier fermé)

Peut-être?

(A adapter, bien sûr)

Option Base 1
Sub essai()
' Microsoft ActiveX DataObject doit être coché
Dim Plg As Range
Dim LesLignes
Dim I As Integer, J As Integer, K As Integer
Dim Cnn As Object, Rs As Object
Dim Tbl
Dim Somme()
ReDim Somme(1 To 196)
Chemin = ThisWorkbook.Path & "\": Feuille = "Feuil1"
LesLignes = Array(9, 11, 16, 18, 23, 25, 30, 32, 37, 39, 44, 46, 51, 53)
Set Plg = Range("A1:N53")
I = 1
For J = LBound(LesLignes) To UBound(LesLignes)
    For K = 1 To 14
        Somme(I) = CDbl(Somme(I)) + CDbl(Plg.Value2(LesLignes(J), K)): I = I + 1
    Next K
Next J
Fichier = Dir(Chemin & "*.xlsm")
Do While Len(Fichier) > 0
    If Fichier <> ThisWorkbook.Name Then
        Set Cnn = New ADODB.Connection
        Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
            Chemin & Fichier & ";Extended Properties='Excel 12.0;HDR=No'"
        Set Rs = Cnn.Execute("[Feuil1$A1:N53]")
        Tbl = Rs.GetRows
        I = 1
        For J = LBound(LesLignes) To UBound(LesLignes)
            For K = 1 To 14
                Somme(I) = CDbl(Somme(I)) + CDbl(Tbl(K - 1, LesLignes(J) - 1)): I = I + 1
            Next K
        Next J
        Rs.Close
        Cnn.Close
    End If
    Fichier = Dir()
Loop
Set Rs = Nothing
Set Cnn = Nothing
With Sheets("Feuil2")
    I = 1
    For J = LBound(LesLignes) To UBound(LesLignes)
        For K = 1 To 14
            .Cells(LesLignes(J), K) = Somme(I): I = I + 1
        Next K
    Next J
End With
End Sub
Le 08/06/2021 à 17:14

cousinhb29

Vraiment mieux. La rapidité est vraiment amélioré.

Est-ce possible de remettre a zéro les lignes du fichier qui recevra les données avant d'effectuer la sommes?

Car a tout les fois que je démarre la macro elle effectue la sommes de la données déjà présentes, aux autres.

Je ne sais pas si je suis assez claire?

Merci

Le 08/06/2021 à 17:34

Autre question!!!

J'ai essayé de mettre à jour ton code en ajoutant des lignes. Mais il me place un message d'erreur à cette ligne.

Somme(I) = CDbl(Somme(I)) + CDbl(Plg.Value2(LesLignes(J), K)): I = I + 1

Erreur: L'indice n'appartient pas à la slection.

Voici le code modifié

Option Base 1
Sub essai()
' Microsoft ActiveX DataObject doit être coché
Dim Plg As Range
Dim LesLignes
Dim I As Integer, J As Integer, K As Integer
Dim Cnn As Object, Rs As Object
Dim Tbl
Dim Somme()

ReDim Somme(1 To 336)
Chemin = ThisWorkbook.Path & "\": Feuille = "Sommaire"
LesLignes = Array(9, 11, 16, 18, 23, 25, 30, 32, 37, 39, 44, 46, 51, 53, 58, 60, 65, 67, 72, 74, 79, 81, 86, 88)
Set Plg = Range("A1:N88")
I = 1
For J = LBound(LesLignes) To UBound(LesLignes)
    For K = 1 To 24
        Somme(I) = CDbl(Somme(I)) + CDbl(Plg.Value2(LesLignes(J), K)): I = I + 1
    Next K
Next J
Fichier = Dir(Chemin & "*.xlsm")
Do While Len(Fichier) > 0
    If Fichier <> ThisWorkbook.Name Then
        Set Cnn = New ADODB.Connection
        Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
            Chemin & Fichier & ";Extended Properties='Excel 12.0;HDR=No'"
        Set Rs = Cnn.Execute("[Sommaire$A1:N88]")
        Tbl = Rs.GetRows
        I = 1
        For J = LBound(LesLignes) To UBound(LesLignes)
            For K = 1 To 24
                Somme(I) = CDbl(Somme(I)) + CDbl(Tbl(K - 1, LesLignes(J) - 1)): I = I + 1
            Next K
        Next J
        Rs.Close
        Cnn.Close
    End If
    Fichier = Dir()
Loop
Set Rs = Nothing
Set Cnn = Nothing
With Sheets("Sommaire")
    I = 1
    For J = LBound(LesLignes) To UBound(LesLignes)
        For K = 1 To 24
            .Cells(LesLignes(J), K) = Somme(I): I = I + 1
        Next K
    Next J
End With
End Sub

Merci

Le 08/06/2021 à 18:17

Re-,

Est-ce possible de remettre a zéro les lignes du fichier qui recevra les données avant d'effectuer la sommes?

J'étais parti de ton code, où tu effectuais cette opération : (et que je ne comprenais pas, d'ailleurs....)

For i = LBound(Cellules) To UBound(Cellules): Somme(i) = CDbl(Application.Sum(Range(Cellules(i)))): Next

Tu supprimes donc la première boucle :

I = 1
For J = LBound(LesLignes) To UBound(LesLignes)
    For K = 1 To 24
        Somme(I) = CDbl(Somme(I)) + CDbl(Plg.Value2(LesLignes(J), K)): I = I + 1
    Next K
Next J

Et lors du remplissage final, les anciennes valeurs seront remplacées dans la dernière boucle

Pour l'autre question, je regarde

Le 08/06/2021 à 18:21

Pour l'autre question,

Le K avait pour valeur max 14, car c'est le nombre de colonnes...

Donc maintiens For K = 1 To 14 dans toutes les boucles

Le 08/06/2021 à 19:18

Désolé.... J'essai de modifier le code,... sans succès.

Le 08/06/2021 à 19:24

Re-,

Sans tester....

PS, juste pour info, combien de temps, avant, avec ton code, puis après?

Option Base 1
Sub essai()
' Microsoft ActiveX DataObject doit être coché
Dim LesLignes
Dim I As Integer, J As Integer, K As Integer
Dim Cnn As Object, Rs As Object
Dim Tbl
Dim Somme()

ReDim Somme(1 To 336)
Chemin = ThisWorkbook.Path & "\": Feuille = "Sommaire"
LesLignes = Array(9, 11, 16, 18, 23, 25, 30, 32, 37, 39, 44, 46, 51, 53, 58, 60, 65, 67, 72, 74, 79, 81, 86, 88)
For J = LBound(LesLignes) To UBound(LesLignes)
    For K = 1 To 14
        Sheets("Sommaire").Cells(LesLignes(J), K).ClearContents
    Next K
Next J
Fichier = Dir(Chemin & "*.xlsm")
Do While Len(Fichier) > 0
    If Fichier <> ThisWorkbook.Name Then
        Set Cnn = New ADODB.Connection
        Cnn.Open "Provider=Microsoft.ACE.OLEDB.12.0;Data Source=" & _
            Chemin & Fichier & ";Extended Properties='Excel 12.0;HDR=No'"
        Set Rs = Cnn.Execute("[Sommaire$A1:N88]")
        Tbl = Rs.GetRows
        I = 1
        For J = LBound(LesLignes) To UBound(LesLignes)
            For K = 1 To 14
                Somme(I) = CDbl(Somme(I)) + CDbl(Tbl(K - 1, LesLignes(J) - 1)): I = I + 1
            Next K
        Next J
        Rs.Close
        Cnn.Close
    End If
    Fichier = Dir()
Loop
Set Rs = Nothing
Set Cnn = Nothing
With Sheets("Sommaire")
    I = 1
    For J = LBound(LesLignes) To UBound(LesLignes)
        For K = 1 To 14
            .Cells(LesLignes(J), K) = Somme(I): I = I + 1
        Next K
    Next J
End With
End Sub
Le 08/06/2021 à 20:17

Merci tu as répondu à toutes mes interrogations

Très efficace!!!

Rechercher des sujets similaires à "augmenter rapidite macro"