Optimisation d'un code VBA (Pour les courageux au grand coeur ^^)

TgR · 31 Mars 2014

Bonjour à tous,

Ma demande va sans doute vous paraitre saugrenue mais j'aurais besoin d'un peu d'aide pour optimiser et organiser un code que j'ai écrit il y a quelques temps déjà. J'aimerais le rendre plus lisible, éventuellement passer par des fonctions etc... J'aimerais juste quelques conseils de la part de personnes expérimentées. Avant de vous copier mon code, je vais d'abord vous exposer comment sont disposées les données puis ce qu'effectue mon code :

DISPOSITION DES DONNEES (La première donnée se trouve toujours en A1) :

LRU1	LRU2	...	LRUX
Composant1	Composant1	...	Composant1
Composant2	Composant2	...	Composant2
ComposantX	ComposantX	...	ComposantX

Mon code va comparer tous les composant des LRU entre eux et faire ressortir le pourcentage de composants communs que chaque LRU possède avec un autre. Ici le code comparerait :

LRU1
Composant1 - LRU2/Composant1
Composant1 - LRU2/Composant2
Composant1 - LRU2/ComposantX
Composant1 - LRU3/ComposantX
etc..

Le résultat est ensuite affiché dans un onglet "Communs". Je vous mets mon code. Il est un peu bordélique mais j'ai tenté de le commenté pour qu'il soit compris facilement (j'espère). C'est un peu indigeste (d'où les courageux au grand coeur). J'espère que quelqu'un aura la patience de m'aider (à me faire progresser ).

Merci

Code:

Option Explicit

Sub comparaison_LRU()
Application.ScreenUpdating = False
Dim debut As Date, temps As Date, fin As Date
debut = Time

Sheets(1).Name = "Tableau"
Sheets(2).Name = "Communs"

Dim boucleGenerale As Integer ' boucle sur toutes les colonnes

'=== Pour connaitre le nombre de colonnes à traiter ======
Dim nbColonnes As Integer
nbColonnes = Range("A1", [A1].End(xlToRight)).Columns.Count
'==========================================================

For boucleGenerale = 1 To nbColonnes
    Dim DerLigLruTest As Integer, DerLigLruSelec As Integer
    Dim ComposantEnCours As Integer, maxComposants As Integer, ComposantTest As Integer, TestEnCours As Integer, caseTab As Integer
    Dim i As Integer, j As Integer
    Dim composantsCommuns As Byte
    Dim tabLruSelect(), tabLruTest(), tabLruCommuns(), tabPourcentage()
    
    caseTab = 0
    
'====================================================================================================
' Selection des composants du LRU dont les composants vont être comparés avec tous les autres
' Composants insérés dans un tableau

    With Sheets("Tableau")
        'Pour obtenir le nombre de ligne du LRU test
        DerLigLruSelec = .Range(.Cells(1, boucleGenerale), .Cells(1, boucleGenerale)).End(xlDown).Row
        'Pour insérer d'un coup toutes les lignes dans un tableau
        tabLruSelect = Range(.Cells(1, boucleGenerale), .Cells(DerLigLruSelec, boucleGenerale))
    End With
    
'=====================================================================================================

    TestEnCours = 1
    maxComposants = (UBound(tabLruSelect) - 1) 'Pour faire la division du pourcentage
   
   Do While TestEnCours < (nbColonnes + 1) 'boucle sur toutes les colonnes suivants afin de comparer les composants avec le LRU test
        composantsCommuns = 0
        If TestEnCours = boucleGenerale Then 'ne pas se comparer avec lui même
           TestEnCours = TestEnCours + 1
        End If
        If TestEnCours > (nbColonnes) Then
            Exit Do
        End If
        With Sheets("Tableau")
            ' même principe que pour DerLigLruSelec mais pour les LRU testés
            DerLigLruTest = .Range(.Cells(1, TestEnCours), .Cells(1, TestEnCours)).End(xlDown).Row
            tabLruTest = Range(.Cells(1, TestEnCours), .Cells(DerLigLruTest, TestEnCours))
        End With
        
        'Comparaison de tous les composants
        For i = 2 To UBound(tabLruSelect) 'commence à 2 car 1 = numéro du LRU
            For j = 2 To UBound(tabLruTest) ' Pareil
            
                If (tabLruSelect(i, 1) = tabLruTest(j, 1)) Then '='
                    composantsCommuns = composantsCommuns + 1   '='
                    caseTab = caseTab + 1                       '='Si communs, ajout du composant dans le tableau des communs
                    ReDim Preserve tabLruCommuns(caseTab)       '='
                    
                    '================================================================
                    
                    'Permet d'éviter les répétitions  de LRU select dans le tableau
                    If Not tabLruCommuns(caseTab - 1) = tabLruTest(1, 1) Then
                        tabLruCommuns(caseTab) = tabLruTest(1, 1)
                    Else
                        caseTab = caseTab - 1
                        ReDim Preserve tabLruCommuns(caseTab)
                    End If
                    '================================================================
                
                End If
            Next j
        Next i
        
        'Si des composants communs existent alors calcul du pourcentage et ajout dans le tableau pourcentag.
        If composantsCommuns <> 0 Then
            ReDim Preserve tabPourcentage(UBound(tabLruCommuns))
            tabPourcentage(UBound(tabPourcentage)) = Round(((composantsCommuns / maxComposants) * 100), 0)
        End If
    TestEnCours = TestEnCours + 1
    Loop
    
    'Sur la première version du programme, lorsque les pourcentages étaient affichés, ils m'était impossible de les trier par ordre croissant
    'J'ai donc décidé de passer par un tableau pourcentage que je trie en parallèle du tableauLruCommuns
    
    ' Tri
    Dim tempPourcent As Double
    Dim tempLru As String
    Dim yapermute As Boolean
        yapermute = True
    While yapermute
        yapermute = False
        For i = 1 To UBound(tabPourcentage) - 1
            If tabPourcentage(i) < tabPourcentage(i + 1) Then
                tempPourcent = tabPourcentage(i)
                tabPourcentage(i) = tabPourcentage(i + 1)
                tabPourcentage(i + 1) = tempPourcent
                
                tempLru = tabLruCommuns(i)
                tabLruCommuns(i) = tabLruCommuns(i + 1)
                tabLruCommuns(i + 1) = tempLru
                yapermute = True
            End If
        Next i
    Wend
    
    ' concatenation des composants communs avec leur pourcentage
    For i = 1 To UBound(tabLruCommuns)
        tabLruCommuns(i) = tabPourcentage(i) & "%" & " " & tabLruCommuns(i)
    Next i
    
    'Affiche du résultat sur la feuille "Communs"
    With Sheets("Communs")
        .Cells(boucleGenerale, 1).Value = tabLruSelect(1, 1)
        .Cells(boucleGenerale, 2).Resize(1, UBound(tabLruCommuns) + 1).Value = tabLruCommuns
    End With
Next boucleGenerale

    fin = Time
    temps = fin - debut
    MsgBox ("C'est fini !" & Chr(10) & "temps de traitement " & temps)
End Sub

TgR · 11 Août 2014

Re : Optimisation d'un code VBA (Pour les courageux au grand coeur ^^)

Salut Roger,

Il semblerait que mon message précédent n'ai pas été posté. je recommence donc. J'essaye d'ajouter la macro que tu as réalisée à d'autres qui s'occupent de traitements préalables. Malheureusement, et je ne sais pas pourquoi, je me retrouve avec un message d'erreur "mémoire insuffisante" lors de l'instruction suivante de ton code :

Code:

Comptage = Array(w, c)

De plus, là aussi je ne sais pas pourquoi, ton code qui était si rapide à s'exécuter est maintenant trèèèès lent.

Les macros que j'utilise au préalable réalisent pourtant des actions très basiques, je me demande donc pourquoi je me retrouve avec une mémoire insuffisante. Voici les étapes de mes macros :

- Création d'un TCD à partir d'une base de données faisant 250 000 lignes
- Copié/collé des lignes filtrées qui m'intéressent = 6500 environ
- Suppression de données supplémentaires dans ces lignes = plus que 3200 lignes.
- Lancement d'une macro permettant de mettre les données en colonne (pour pouvoir appliquer ta macro)
- Lancement de la macro que tu as réalisée
- Erreur => mémoire insuffisante

Voici le code de mes macros :

Code:

Sub CreatePivot()
   Application.ScreenUpdating = False
   Application.Calculation = xlCalculationManual
   Application.CutCopyMode = False
   
   Dim objTable As PivotTable, objField As PivotField
   ActiveWorkbook.Sheets("Feuil1").Select
   Range("A1").Select
   
   Sheets.Add.Move After:=Sheets(Sheets.Count)
   Sheets(Sheets.Count).Name = "TCD"
     
   Worksheets("TCD").PivotTableWizard _
   SourceType:=xlDatabase, _
   SourceData:=Worksheets("Feuil1").Range("A:Q").Address(, , xlR1C1, True), _
   TableDestination:=Worksheets("TCD").Range("A1"), _
   tableName:="TCD_1"
   
   Set objTable = Worksheets("TCD").PivotTables("TCD_1")
   
   Set objField = objTable.PivotFields("Article")
   objField.Orientation = xlRowField
   Set objField = objTable.PivotFields("Composant")
   objField.Orientation = xlRowField
   Set objField = objTable.PivotFields("Nb Dmd rep")
   objField.Orientation = xlDataField

   Set objField = objTable.PivotFields("Div.")
   objField.Orientation = xlPageField
   objField.CurrentPage = "1000"
   
   Set objField = Nothing
   Set objTable = Nothing
   Call miseEnColonne
End Sub
Sub miseEnColonne()
   Application.ScreenUpdating = False
   Dim maPlage As Range
   
   Sheets.Add.Move After:=Sheets(Sheets.Count)
   Sheets(Sheets.Count).Name = "Tableau"
   Sheets("TCD").Activate
   Set maPlage = Sheets("TCD").Range(Range("A4"), Range("B1048576").End(xlUp))
   maPlage.Copy Destination:=Sheets("Tableau").Range("A1")
   Set maPlage = Nothing

   '----- Filtrage --------------------------------
   Sheets("Tableau").Activate
   Rows("1:1").Delete
   Range("A:B").AutoFilter Field:=1, _
                           Criteria1:="=*Total*", _
                           Operator:=xlAnd
   Range("A2").Select
   Range(Selection, Selection.End(xlDown)).Select
   Selection.ClearContents
   Range("A:B").AutoFilter Field:=1, _
                           Criteria1:="(vide)", _
                           Operator:=xlAnd
   Range("A2:B2").Select
   Range(Selection, Selection.End(xlDown)).Select
   Selection.ClearContents
   
   ActiveSheet.Range("A1").AutoFilter Field:=1
   Range("A:B").AutoFilter Field:=2, _
                           Criteria1:="=*FLU*", _
                           Operator:=xlAnd
   Range("B2").Select
   Range(Selection, Selection.End(xlDown)).Select
   Selection.ClearContents
   ActiveSheet.Range("A1").AutoFilter Field:=2
   
   '----------------------------------------------
                           
   Application.DisplayAlerts = False
   Application.DisplayAlerts = True
   Call Vider_le_Presse_Papier

   Dim celluleRef          As Range
   Dim LRU                 As Range
   Dim cellComposants      As Range
   Dim nbLignes            As Long
   Dim decalageCellule     As Long
   Dim tableauComposants() As String
   Dim indice              As Long
   
   Set celluleRef = Range("A1")
   Set LRU = Range("D1")
   
   nbLignes = Range("A" & Rows.Count).End(xlUp).Row
   decalageCellule = 0
   indice = 2
   
   While (indice < nbLignes)
      If celluleRef.Cells(indice) <> "" Then
         Dim iComposants   As Integer
         Dim i             As Integer
         Dim nbLig         As Integer
              
         Set cellComposants = celluleRef.Cells(indice, 2)
         cellComposants.Select
         nbLig = Range(Selection, Selection.End(xlDown)).Rows.Count - 1
         ReDim tableauComposants(nbLig + 1)
         iComposants = 1
         tableauComposants(iComposants) = celluleRef.Cells(indice)
         iComposants = iComposants + 1
         
         For i = 1 To nbLig
            If Not (cellComposants.Cells(i) = "FLU") Then
              tableauComposants(iComposants) = cellComposants.Cells(i)
              iComposants = iComposants + 1
            End If
         Next i
         LRU.Offset(0, decalageCellule).Select
         For iComposants = 1 To UBound(tableauComposants)
            LRU.Cells(iComposants, decalageCellule).Value = tableauComposants(iComposants)
         Next iComposants
         decalageCellule = decalageCellule + 1
      End If
      indice = indice + 1
   Wend
   
   Erase tableauComposants()
   Set celluleRef = Nothing
   Set cellComposants = Nothing
   Set LRU = Nothing
   Call tutu
End Sub

La seule chose qui change dans la macro tutu (que tu as réalisée) est le changement d'une cellule de départ.

Comment puis-je faire en sorte que tout fonctionne de nouveau ?

TgR · 11 Août 2014

Re : Optimisation d'un code VBA (Pour les courageux au grand coeur ^^)

Je m'aperçois qu'en lançant la macro tutu seule, comme avant, elle met énormément de temps aussi alors qu'avant le résultat était quasi instantané ! Bizarre...

ROGER2327 · 12 Août 2014

Re : Optimisation d'un code VBA (Pour les courageux au grand coeur ^^)

Re...

TgR à dit:
Je m'aperçois qu'en lançant la macro tutu seule, comme avant, elle met énormément de temps aussi alors qu'avant le résultat était quasi instantané ! Bizarre...

Bizarre en effet. D'autant plus que je livre rarement un code sans le tester.

Je viens de faire une nouvelle série d'essais avec cette procédure de test :

VB:

Sub Test()
Dim i&, k&, c&, l&, lk(), t0!, t1!
Const n& = 10
  lk = Array(100&, 200&, 500&, 1000&, 2000&, 5000&, 10000&)
For i = 1 To n
  k = 0
  For c = 5 To 50 Step 5
    For l = 0 To UBound(lk)
      Remplir CLng(lk(l)), c
      t0 = Timer
      Tutu
      t1 = Timer
      With Feuil3.[A2]
        If i = 1 Then .Resize(1, 2).Offset(k).Value = Array(c, lk(l))
        .Offset(k, i + 1).Value = t1 - t0 - 86400 * (t1 < t0)
      End With
      DoEvents
      k = k + 1
  Next l, c, i
End Sub

Private Sub Remplir(l&, c&)
Dim i&, j&, a&, b&, v()
  With Worksheets("Tableau").[A1]
    .CurrentRegion.Clear
    ReDim v(Int(l * 1.1), 1 To c)
    For j = 1 To c
      v(0, j) = "C" & Format(j, "000")
      a = WorksheetFunction.RandBetween(1, 500): b = a + WorksheetFunction.RandBetween(0, 499)
      For i = 1 To WorksheetFunction.RandBetween(Int(l * 0.9), Int(l * 1.1)): v(i, j) = WorksheetFunction.RandBetween(a, b)
    Next i, j
    .Resize(Int(l * 1.1) + 1, c).Value = v
  End With
End Sub

La procédure Test appelle la procédure Remplir avec les paramètres l et c. Remplir crée des données dans l'onglet Tableau sur c colonnes, et sur l lignes, ± 10 %.
Test appelle ensuite Tutu et en relève la durée d'exécution ; c, l et la durée d'exécution sont inscrites dans l'onglet Test.
Le couple (c ; l) prend ses valeurs dans l'ensemble

{5 ; 10 ; 15 ; 20 ; 25 ; 30 ; 35 ; 40 ; 45 ; 50} × {100 ; 200 ; 500 ; 1000 ; 2000 ; 5000 ; 10000}

Le test est répété dix fois (compter pas loin d'une demi-heure pour l'exécution complète des sept cents essais).
Résultat constaté : les durées d'exécution s'échelonnent de moins de 0,2 s à 8 s environ.
Voyez le détail du résultat dans le classeur joint.

Je ne peux en dire plus sans connaissance précise de l'environnement dans lequel vous exécutez le code.

Bon courage.

ℝOGER2327
#7499

Lundi 2 Phalle 141 (*Sainte Ruth, zélatrice - fête Suprême Quarte)
25 Thermidor An CCXXII, 0,3346h - loutre
2014-W33-2T00:48:11Z

TgR · 12 Août 2014

Re : Optimisation d'un code VBA (Pour les courageux au grand coeur ^^)

Salut,

Merci ! Mais Il n'était pas nécessaire de revérifier sur ta machine, j'ai déjà pu constater avec joie par le passé que ta macro est très rapide. Je dois certainement avoir fait quelque chose sur mon excel pour que celle-ci soit devenue si lente. Aurais-tu cependant une idée qui me permettrait de contourner cette "mémoire insuffisante" ?

Je joins le fichier nettoyé des colonnes que je n'utilise pas dans ma macro (pour l'alléger). J'ai également supprimé le contenu des lignes, mais celui-ci en contient exactement 265 512 et sont toutes remplies.

Je pense que ma macro de mise en colonne peut être supprimée en modifiant la macro tutu (que tu avais conçu selon ce modèle que j'avais demandé), cependant je ne te cache pas que je ne suis pas très à l'aise avec ton code ^^

Si tu as le temps de m'aider, ça serait sympa.

Merci d'avance.

ps : Je travaille sur excel 2010.

ROGER2327 · 13 Août 2014

Re : Optimisation d'un code VBA (Pour les courageux au grand coeur ^^)

Suite...

Un essai de modification de mon précédent code, pour tenir compte de la nouvelle présentation des données. Je n'utilise pas d'autres onglets que Tableau et Communs.
La procédure Tutu est à peine modifiée, Classement est inchangée, seule Comptage est sérieusement remaniée.

VB:

Sub Tutu()
Dim w()

    On Error GoTo E1 'pour le cas où il n'existerait pas de feuille nommée "Tableau"
    w = Comptage(Worksheets("Tableau"), "Article", "Composant") 'le comptage est effectué par une fonction auxiliaire

    On Error GoTo E2 'pour le cas où il n'existerait pas de feuille nommée "Communs"
    With Worksheets("Communs").[A1] 'affichage des résultats
    On Error GoTo E3 'pour le cas de problème non identifié
    With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
        .CurrentRegion.ClearContents
        .Resize(w(1) + 1, w(1) + 2).Value = Classement(w(0)) 'traitement pour affichage
R:  With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
    End With

Exit Sub

'Gestion des erreurs

E1:  MsgBox "Je n'ai pas trouvé la feuille de données.", vbOKOnly, "Cornegidouille !"
End

E2:  MsgBox "Je n'ai pas trouvé la feuille de résultats.", vbOKOnly, "Merdre !"
End

E3:  MsgBox "De par ma chandelle verte, ça coince !", vbOKOnly, "? ? ?"
Resume R

End Sub

Private Function Classement(z)
Dim i&, j&, n&, k&, l&, a&, b&, tmp, u(), v()
  a = UBound(z, 1): b = UBound(z, 2)
  ReDim u(1 To b), v(1 To a, b)
  For i = 1 To a 'construction du tableau de résultats ligne par ligne
    v(i, 0) = z(i, 0)
    For j = 1 To b 'relevé des données utiles
      If Not IsEmpty(z(i, j)) Then n = n + 1: u(n) = z(i, j): v(i, n) = Format(z(i, j), "#0.0%") & " " & z(0, j)
    Next
    For k = 1 To n 'classement de la ligne par valeurs décroissantes
      tmp = u(k)
      For l = 1 To n
        If u(l) < tmp Then u(k) = u(l): u(l) = tmp: tmp = v(i, k): v(i, k) = v(i, l): v(i, l) = tmp: tmp = u(k)
      Next
    Next
    n = 0
  Next
  Classement = v
End Function

'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤'
'¤                                                        ¤'
'¤        Ajouter la référence à la bibliothèque          ¤'
'¤  Microsoft Scripting Runtime (scrrun.dll) au projet !  ¤'
'¤                                                        ¤'
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤'

Private Function Comptage(Feuille As Worksheet, Champ1$, Champ2$)
Dim h&, i&, j&, k&, l&, m&, n&, s$, w(), art(), com(), Cel As Range
Dim sd As New Scripting.Dictionary, sdk(), sdi(), t()
Dim ad As New Scripting.Dictionary

  With Feuille.[A1]
    If Not IsEmpty(.Offset(, 1)) Then
      For Each Cel In Range(.Cells, .End(xlToRight))
        If Not IsEmpty(Cel.Offset(1)) Then
          Select Case CStr(Cel.Value)
          Case Champ1: art = Range(Cel, Cel.End(xlDown)).Value: i = i + 1
          Case Champ2: com = Range(Cel, Cel.End(xlDown)).Value: i = i + 2
          End Select
        End If
      Next
    End If
    If i = 3 Then
      If UBound(art) = UBound(com) Then
        l = UBound(art)
        For i = 2 To l
          If Not IsEmpty(art(i, 1)) And Not IsEmpty(com(i, 1)) Then
            If CStr(com(i, 1)) <> "FLU" Then
              s = CStr(art(i, 1))
              If sd.Exists(s) Then
                t = sd(s)
                For j = 0 To UBound(t): ad.Add CStr(t(j)), Empty: Next
                If Not ad.Exists(CStr(com(i, 1))) Then
                  ReDim Preserve t(1 + UBound(t))
                  t(UBound(t)) = CStr(com(i, 1))
                  sd(s) = t
                End If
                Set ad = Nothing
              Else
                sd.Add s, Array(CStr(com(i, 1)))
              End If
            End If
          End If
        Next
        sdk = sd.Keys: sdi = sd.Items
        l = UBound(sdk)
        ReDim w(l + 1, l + 1)
        Set sd = Nothing
        For h = 0 To l
          w(h + 1, 0) = sdk(h): w(0, h + 1) = sdk(h)
          For i = 0 To l
            If h <> i Then
              For j = 0 To UBound(sdi(h)): For k = 0 To UBound(sdi(i))
                If sdi(h)(j) = sdi(i)(k) Then m = m + 1: n = n + 1
              Next k, j
              If m Then w(h + 1, i + 1) = m / j: w(i + 1, h + 1) = n / k: m = 0: n = 0
            End If
          Next
        Next
      End If
    End If
  End With

  Comptage = Array(w, l)

End Function

Attention ! Pour une fois, je n'ai pas eu le temps de faire des essais sérieux avec un grand nombre de données.
Pas le courage de fabriquer les données.
À tester...

Bonne journée.

ℝOGER2327
#7501

Mardi 3 Phalle 141 (Saint Zebb, passe - partout - fête Suprême Quarte)
26 Thermidor An CCXXII, 1,8252h - myrthe
2014-W33-3T04:22:50Z

TgR · 13 Août 2014

Re : Optimisation d'un code VBA (Pour les courageux au grand coeur ^^)

Salut Roger,

Encore merci d'avoir pris le temps de te pencher sur mon problème. J'ai exécuté la macro sur le fichier complet, je n'ai pas mesuré avec précision mais elle met environ 4mn à s'exécuter et s'exécute sans encombres. Cela me convient parfaitement.

Je vais profiter du post pour te demander :

Certaines instructions comme scripting.dictionnary me sont totalement inconnues. Aurais-tu des liens vers des tutos me permettant d'apprendre ce genre de choses ?

Même question pour le script run.dll ^^

Merci beaucoup !!!

TgR

TgR · 13 Août 2014

Re : Optimisation d'un code VBA (Pour les courageux au grand coeur ^^)

==> Developpez.net

^^

ROGER2327 · 13 Août 2014

Re : Optimisation d'un code VBA (Pour les courageux au grand coeur ^^)

Suite...

Tant mieux si ça fonctionne ! Mais c'est bien lent.

Voici une variante de la procédure Comptage qui devrait nettement accélérer la manœuvre :

VB:

'·¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤·'
'¤                                                          ¤'
'¤         Ajouter la référence à la bibliothèque           ¤'
'¤   Microsoft Scripting Runtime (scrrun.dll) au projet !   ¤'
'¤                                                          ¤'
'·¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤·'
'¤                                                          ¤'
'¤ Cette bibliothèque permet l'accès de l'application       ¤'
'¤ à l'objet Scripting.Dictionary.                          ¤'
'¤                                                          ¤'
'¤ À défaut, remplacer :                                    ¤'
'¤                                                          ¤'
'¤   Dim sd As New Scripting.Dictionary                     ¤'
'¤                                                          ¤'
'¤ par :                                                    ¤'
'¤                                                          ¤'
'¤   Dim sd As Object                                       ¤'
'¤      Set sd = CreateObject("Scripting.Dictionary")       ¤'
'¤                                                          ¤'
'·¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤·'

Private Function Comptage(Feuille As Worksheet, Champ1$, Champ2$)
Dim h&, i&, j&, k&, l&, m&, n&, s$, w(), Art(), Com(), Cel As Range
Dim Sd As New Scripting.Dictionary, SdK(), SdI(), t()

  With Feuille.[A1]
    If Not IsEmpty(.Offset(, 1)) Then
      For Each Cel In Range(.Cells, .End(xlToRight))
        If Not IsEmpty(Cel.Offset(1)) Then
          Select Case CStr(Cel.Value)
          Case Champ1: Art = Range(Cel, Cel.End(xlDown)).Value: i = i + 1
          Case Champ2: Com = Range(Cel, Cel.End(xlDown)).Value: i = i + 2
          End Select
        End If
      Next
    End If
    If i = 3 Then
      If UBound(Art) = UBound(Com) Then
        l = UBound(Art)
        For i = 2 To l
          If Not IsEmpty(Art(i, 1)) And Not IsEmpty(Com(i, 1)) Then
            If CStr(Com(i, 1)) <> "FLU" Then
              s = CStr(Art(i, 1))
              If Sd.Exists(s) Then
                t = Sd(s)
                For j = 0 To UBound(t)
                  If StrComp(Com(i, 1), t(j), 0) = 0 Then Exit For
                Next
                If j > UBound(t) Then
                  ReDim Preserve t(1 + UBound(t))
                  t(UBound(t)) = CStr(Com(i, 1))
                  Sd(s) = t
                End If
              Else
                Sd.Add s, Array(CStr(Com(i, 1)))
              End If
            End If
          End If
        Next
        SdK = Sd.Keys: SdI = Sd.Items
        l = UBound(SdK)
        ReDim w(l + 1, l + 1)
        Set Sd = Nothing
        For h = 0 To l
          w(h + 1, 0) = SdK(h): w(0, h + 1) = SdK(h)
          For i = 0 To l
            If h <> i Then
              For j = 0 To UBound(SdI(h)): For k = 0 To UBound(SdI(i))
                If SdI(h)(j) = SdI(i)(k) Then m = m + 1: n = n + 1
              Next k, j
              If m Then w(h + 1, i + 1) = m / j: w(i + 1, h + 1) = n / k: m = 0: n = 0
            End If
          Next
        Next
      End If
    End If
  End With

  Comptage = Array(w, l)

End Function

Pas de changement pour le reste.

Essayez et dites-moi ! Merci !

Bonne journée.

ℝOGER2327
#7502

Mardi 3 Phalle 141 (Saint Zebb, passe - partout - fête Suprême Quarte)
26 Thermidor An CCXXII, 5,4438h - myrthe
2014-W33-3T13:03:55Z

P.s. : L'aide fournie avec le logiciel permet aussi d'apprendre beaucoup de choses : usez et abusez de la touche F1 !

TgR · 14 Août 2014

Re : Optimisation d'un code VBA (Pour les courageux au grand coeur ^^)

Salut,

Après tests sur mes données réelles, le traitement sur les 127 000 lignes (après tri) prend environ 5mn. J'ai également testé sur mon ordi personnel, le traitement prend le même temps.

Merci Roger !

TgR · 3 Septembre 2014

Re : Optimisation d'un code VBA (Pour les courageux au grand coeur ^^)

Hello Roger,

Au risque de paraitre un peu lourd, te serait-il possible de commenter un peu ta macro pour que je comprennes un peu mieux ? Je suis en train d'essayer de comprendre mais je suis sur que certains détails m'échappent.

Merci d'avance.

ROGER2327 · 3 Septembre 2014

Re : Optimisation d'un code VBA (Pour les courageux au grand coeur ^^)

Re...

(...) te serait-il possible de commenter un peu ta macro (...)

Sûr que quelques commentaires peuvent être utiles ! Si je ne commente pas systématiquement mes codes, c'est que :

c'est chronophage ;
les codes sont généralement simples ;
nombre de demandeurs ne reviennent pas voir les réponses proposées.

Lorsque, par hasard, un code intéresse quelqu'un, il va de soi que je commente.

VB:

Private Function Comptage(Feuille As Worksheet, Champ1$, Champ2$)
Dim h&, i&, j&, k&, l&, m&, n&, s$, w(), Art(), Com(), Cel As Range
Dim Sd As New Scripting.Dictionary, SdK(), SdI(), t()

  With Feuille.[A1]

'On s'assure qu'il existe des données à traiter dans la feuille <Feuille> :

    If Not IsEmpty(.Offset(, 1)) Then
      For Each Cel In Range(.Cells, .End(xlToRight))
        If Not IsEmpty(Cel.Offset(1)) Then
          Select Case CStr(Cel.Value)
          Case Champ1: Art = Range(Cel, Cel.End(xlDown)).Value: i = i + 1
          Case Champ2: Com = Range(Cel, Cel.End(xlDown)).Value: i = i + 2
          End Select
        End If
      Next
    End If

'À ce stade, <i> a l'une des valeurs 0, 1, 2 ou 3.
'<i>  |   Commentaire.
' 0   |   Il n'y a ni 'Champ1' ni 'Champ2'.
' 1   |   'Champ1' a été trouvé ; ses valeurs sont chargées dans <Art> ; il n'y a pas de 'Champ2'.
' 2   |   'Champ2' a été trouvé ; ses valeurs sont chargées dans <Com> ; il n'y a pas de 'Champ1'.
' 3   |   'Champ1' et 'Champ2' ont été trouvés ; leurs valeurs respectives sont chargées dans <Art> et <Com>.
'Note : La réussite de ce processus suppose que la base de données est correctement structurée en
'ce sens qu'il n'existe pas deux champs de même nom.

'Sous l'hypothèse que les deux champs existent et comportent le même nombre de données, on traite
'les données de <Art> et <Com> :

    If i = 3 Then
      If UBound(Art) = UBound(Com) Then
        l = UBound(Art)
        For i = 2 To l
          If Not IsEmpty(Art(i, 1)) And Not IsEmpty(Com(i, 1)) Then
          
'On place les items de <Com> différents de "FLU" dans le dictionnaire <Sd> :
'pour chaque item distinct, on crée un enregistrement (clef CStr(Com(i, 1)) et
'on associe à la clef les la liste des items distincts de <Art> correspondants.

            If CStr(Com(i, 1)) <> "FLU" Then
              s = CStr(Art(i, 1))
              If Sd.Exists(s) Then
                t = Sd(s)
                For j = 0 To UBound(t)
                  If StrComp(Com(i, 1), t(j), 0) = 0 Then Exit For
                Next
                If j > UBound(t) Then
                  ReDim Preserve t(1 + UBound(t))
                  t(UBound(t)) = CStr(Com(i, 1))
                  Sd(s) = t
                End If
              Else
                Sd.Add s, Array(CStr(Com(i, 1)))
              End If
            End If
          End If
        Next

'On récupère les clefs et les items du dictionnaire, et on efface le dictionnaire :

        SdK = Sd.Keys: SdI = Sd.Items
        l = UBound(SdK)
        Set Sd = Nothing

'On crée un tableau <w> à double entrée. Dans la première ligne (de w(0,1) à w(0,l)) et
'la première colonne (de w(1,0) à w(l,0), on place la liste des clefs. On place le taux
'd'items de w(0,h) qui appartiennent à w(i,0) dans w(i,h) :

        ReDim w(l + 1, l + 1)
        For h = 0 To l
          w(h + 1, 0) = SdK(h): w(0, h + 1) = SdK(h)
          For i = 0 To l
            If h <> i Then
              For j = 0 To UBound(SdI(h)): For k = 0 To UBound(SdI(i))
                If SdI(h)(j) = SdI(i)(k) Then m = m + 1: n = n + 1
              Next k, j
              If m Then w(h + 1, i + 1) = m / j: w(i + 1, h + 1) = n / k: m = 0: n = 0
            End If
          Next
        Next
      End If
    End If
  End With

  Comptage = Array(w, l)

End Function

Si des points de détails nécessitent des explications, n'hésitez pas à les demander.

Bonne journée.

ℝOGER2327
#7531

Mardi 24 Phalle 141 (Sainte Orchidée, aumonière - fête Suprême Quarte)
17 Fructidor An CCXXII, 4,8591h - cardière
2014-W36-3T11:39:42Z

TgR · 3 Septembre 2014

Re : Optimisation d'un code VBA (Pour les courageux au grand coeur ^^)

Salut Roger,

En effet je demande de l'aide mais j'aimerais surtout progresser et cela passe aussi par l'analyse de macro d'autrui ^^

Un grand merci à toi

Optimisation d'un code VBA (Pour les courageux au grand coeur ^^)

TgR

XLDnaute Junior

TgR

XLDnaute Junior

TgR

XLDnaute Junior

ROGER2327

XLDnaute Barbatruc

Pièces jointes

TgR

XLDnaute Junior

Pièces jointes

ROGER2327

XLDnaute Barbatruc

Pièces jointes

TgR

XLDnaute Junior

TgR

XLDnaute Junior

ROGER2327

XLDnaute Barbatruc

TgR

XLDnaute Junior

TgR

XLDnaute Junior

ROGER2327

XLDnaute Barbatruc

TgR

XLDnaute Junior

Discussions similaires