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

TgR

XLDnaute Junior
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) :

LRU1LRU2...LRUX
Composant1Composant1...Composant1
Composant2Composant2...Composant2
ComposantXComposantX...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

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

Salut,

J'ai mis un fichier en pièce jointe. Pour les colonnes ABC, la ligne 1 représente les référence des pièces et toutes les lignes qui suivent (je les ai généré aléatoirement) représente les références des composants de ces pièces.7


Merci :)
 

Pièces jointes

  • exemple code.xls
    61 KB · Affichages: 51
  • exemple code.xls
    61 KB · Affichages: 51
  • exemple code.xls
    61 KB · Affichages: 60

Paf

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

bonjour,

dans la feuille Communs on obtient ce résultat:
C221010 92% C222011 73% C22325
C222011 90% C221010 80% C22325
C22325 90% C222011 86% C221010

si j'ai compris, cela signifie que
C221010 a 92% de composants en commun avec C222011 et 73% avec C22325
C222011 a 90% de composants en commun avec C221010 et 80% avec C22325
C22325 a 90% de composants en commun avec C222011 et 86% avec C221010

mais pourquoi :
le % de commun entre C221010 et C222011 est-il différent de celui entre C222011 et C221010
le % de commun entre C221010 et C22325 est-il différent de celui entre C22325 et C221010
le % de commun entre C221011 et C22325 est-il différent de celui entre C22325 et C221011

est ce dû a des règles particulières ?

Pourriez vous les préciser?

A+
 
Dernière édition:

TgR

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

Bonjour,

Oui, tu as bien compris. :)

Si la pièce A possède plus de composants que la pièces B il est normal que le pourcentage change de l'un à l'autre. Par exemple si A possède 2 pièces et B n'en possède qu'une et que l'une de ces pièces est commune aux deux, l'un aura 50% de communalité et l'autre 100%.
 

Grand Chaman Excel

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

Bonjour,

Voici un code à essayer. Toutefois, je n'obtiens pas le même résultat. Donc, avant d'aller plus loin, svp préciser quel serait le résultat attendu en supposant les données du fichier joint (quelques pièces seulement).

Est-ce possible d'avoir un % > 100% ????

Voir onglet "Communs" pour comparaison des résultats des 2 codes.


VB:
Sub Comparaison()
    Dim ar
    Dim i As Long, k As Long, n As Long, j As Long
    Dim Dic1, Dic2
    Dim arPieces1, arPieces2
    Dim NbPieces As Integer, NbCommunes As Integer

    ar = Sheets(1).Cells(1).CurrentRegion.Value

    For k = 1 To UBound(ar, 2)
        For n = 1 To UBound(ar, 2)
            If n <> k Then
                'Create dictionaries
                Set Dic1 = CreateObject("scripting.dictionary")
                Set Dic2 = CreateObject("scripting.dictionary")

                For j = 2 To UBound(ar, 1)
                    If ar(j, k) <> "" Then
                        If Not Dic1.exists(ar(j, k)) Then Dic1.Add ar(j, k), 1 Else Dic1(ar(j, k)) = Dic1(ar(j, k)) + 1
                    End If
                Next j

                For j = 2 To UBound(ar, 1)
                    If ar(j, n) <> "" Then
                        If Not Dic2.exists(ar(j, n)) Then Dic2.Add ar(j, n), 1 Else Dic2(ar(j, n)) = Dic2(ar(j, n)) + 1
                    End If
                Next j

                arPieces1 = Dic1.keys
                NbPieces = Application.Sum(Dic1.items)
                arPieces2 = Dic2.keys

                NbCommunes = 0
                For j = LBound(arPieces2) To UBound(arPieces2)
                    If Dic1.exists(arPieces2(j)) Then NbCommunes = NbCommunes + Application.Min(Dic1(arPieces2(j)), Dic2(arPieces2(j)))
                Next j

                'Résultats
                Debug.Print ar(1, k); vbTab; Format(NbCommunes / NbPieces, "0.00%"); " with "; ar(1, n)
                
                With Sheets(2).Range("A60000").End(xlUp)
                    .Offset(1, 0) = ar(1, k)
                    .Offset(1, 1) = Format(NbCommunes / NbPieces, "0.00%") & " with " & ar(1, n)
                End With
                
            End If
        Next n

    Next k
End Sub
 

Pièces jointes

  • exemple code.xls
    70 KB · Affichages: 48
  • exemple code.xls
    70 KB · Affichages: 48
  • exemple code.xls
    70 KB · Affichages: 51

ROGER2327

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

Bonjour à tous.


Un autre code, tenant compte des doublons...​
VB:
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤'
'¤                                                        ¤'
'¤        Ajouter la référence à la bibliothèque          ¤'
'¤  Microsoft Scripting Runtime (scrrun.dll) au projet !  ¤'
'¤                                                        ¤'
'¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤¤'

Sub toto()
Dim i&, j&, k&, l&, c&, d&, m&, n&, s$, v(), w()
Dim sd As New Scripting.Dictionary, rk(), ri(), qk(), qi()
  With Feuil1.[A1]
    c = .End(xlToRight).Column 'compte les colonnes de données
    c = -c * (c < .Parent.Columns.Count) 'c=0 si moins de deux colonnes
    ReDim w(c, c) 'dimensionne le tableau de résultats
    If c Then
      ReDim v(0 To c - 1, 1) 'tableau annexe
      For i = 0 To c - 1 'pour chaque colonne...
        w(i + 1, 0) = .Offset(, i).Value: w(0, i + 1) = .Offset(, i).Value '...relève l'intitulé de la colonne
        d = .Offset(, i).End(xlDown).Row '...compte le nombre de lignes utiles
        d = -d * (d < .Parent.Rows.Count) 'd=0 si aucune ligne utile
        For j = 1 To d - 1 'relève et compte les items de la colonne (dictionnaire temporaire)
          s = CStr(.Offset(j, i).Value)
          If sd.Exists(s) Then sd(s) = 1 + sd(s) Else sd.Add s, 1&
        Next
        v(i, 1) = d - 1 'tableau annexe : colonne 1=nb. d'items
        Set v(i, 0) = sd 'tableau annexe : colonne 0=dictionnaire des items
        Set sd = Nothing 'réinitialise le dictionnaire temporaire
      Next
      For i = 0 To c - 2 'comparaison deux-à-deux des dictionnaires
        rk = v(i, 0).Keys: ri = v(i, 0).Items
        For j = i + 1 To c - 1
          qk = v(j, 0).Keys: qi = v(j, 0).Items
          For k = 0 To v(i, 0).Count - 1
            For l = 0 To v(j, 0).Count - 1
              If qk(l) = rk(k) Then n = n + ri(k): m = m + qi(l) 'compte les items communs
            Next
          Next
          w(i + 1, j + 1) = n / v(i, 1) 'calcul du taux d'items de la colonne j dans la colonne i
          w(j + 1, i + 1) = m / v(j, 1) 'calcul du taux d'items de la colonne i dans la colonne j
          n = 0: m = 0 'réinitialise les compteurs
        Next
      Next
    End If
  End With

  On Error GoTo E 'pour le cas où il n'existerait pas de feuille nommée "Onglet 3"
  With Worksheets("Onglet 3").[A1] 'affichage des résultats
  With Application: .ScreenUpdating = 0: .EnableEvents = 0: .Calculation = -4135: End With
    .CurrentRegion.ClearContents
    .Resize(c + 1, c + 1).Value = w
    .Offset(1, 1).Resize(c, c).NumberFormat = "#0.0%"
  With Application: .Calculation = -4105: .EnableEvents = 1: .ScreenUpdating = 1: End With
  End With

Exit Sub

E:  MsgBox "Je n'ai pas trouvé la feuille de destination.", vbOKOnly, "Cornegidouille !"

End Sub


ℝOGER2327
#7226


Vendredi 13 Clinamen 141 (Nativité de Maldoror, corsaire aux cheveux d’or - fête Suprême Quarte)
15 Germinal An CCXXII, 1,4442h - abeille
2014-W14-5T03:27:58Z
 

Pièces jointes

  • exemple code_1.xls
    73 KB · Affichages: 54

TgR

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

Salut à vous deux et merci d'avoir pris du temps pour créer des macros.

Grand Chaman,

Ta macro, bien que plus condensé que la mienne, n'est pas plus rapide. Je l'ai testé sur 120 composants (données réelles), l'affichage était correct mais pas immédiat (contrairement à ma macro). De plus l'affichage des données n'est pas le même que le mien à savoir :

C1 100% C2 45% C3 34%CX
C2 95% Cx X% C% ....


Les pourcentages étaient triés par ordre croissant et les 0% n'étaient pas affichés. Cette manière d'afficher me semble être la mieux puisqu'elle me permet ensuite de filtrer par composant et de voir d'un coup les plus gros pourcentages de ceux-ci. Cependant, je vais étudier ton code de près car je ne connais pas les dictionaries, ça sera pour moi l'occasion de découvrir cette notion.

ROGER

Ton code est plus condensé et plus rapide que le mien (2mn en moins sur la totalité des composants, 3047). Cependant, ici aussi l'affichage n'est pas convenable (je fais un peu mon roi ? ^^). Avec ton mode d'affichage, je peux filtrer mes composants, cependant les gros pourcentages ne sautent pas aux yeux et les 0% apparaissent.

Je ne suis pas braqué sur la manière d'afficher mais pour le moment cela ne correspond pas à ce que je recherche. Par contre, ton code étant trop compliqué pour moi (beaucoup de notions que je ne connais pas), il ne me semble pas possible de pouvoir le modifier sans ton aide.

Merci encore à vous
 
Dernière édition:

Grand Chaman Excel

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

@ Tgr

Le code n'est encore pas optimisé. Avant de le faire, j'aimerais savoir quels sont les résultats attendus.
Voir le fichier joint de mon post précédent avec quelques lignes seulement.
Aussi, peut-on avoir des % > 100% ?
 

TgR

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

Et bien non, impossible d'avoir plus de 100% de composants commun, ça n'aurait aucun sens (un produit ne peux pas avoir 120 pièces communes avec un autre qui n'en a que 100). Ce que j'attends ? j'ai un code qui marche et qui me permet de travailler, je suis venu sur ce forum poster, juste pour voir si mon code était d'une part optimisable (il semblerait que oui, au vu de vos ébauches) et d'autre part s'il était possible de le rendre plus lisible via des fonctions par exemple (dans le but de progresser)

Merci.
 

Paf

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

Bonjour à tous

Bonjour,

Oui, tu as bien compris.

Si la pièce A possède plus de composants que la pièces B il est normal que le pourcentage change de l'un à l'autre. Par exemple si A possède 2 pièces et B n'en possède qu'une et que l'une de ces pièces est commune aux deux, l'un aura 50% de communalité et l'autre 100%.

sur l'essai réalisé les pièces (LRU) ont autant de composant et donc les résultats ne devraient pas être ceux obtenus !

Bonne suite
 

ROGER2327

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

Re...


Et bien non, impossible d'avoir plus de 100% de composants commun, ça n'aurait aucun sens (un produit ne peux pas avoir 120 pièces communes avec un autre qui n'en a que 100). (...)
Oui.​


(...) j'ai un code qui marche (...)
Optimiste.​
Capture7.JPG


ROGER

Ton code est plus condensé et plus rapide que le mien (2mn en moins sur la totalité des composants, 3047). Cependant, ici aussi l'affichage n'est pas convenable (je fais un peu mon roi ? ^^). Avec ton mode d'affichage, je peux filtrer mes composants, cependant les gros pourcentages ne sautent pas aux yeux et les 0% apparaissent.

Je ne suis pas braqué sur la manière d'afficher mais pour le moment cela ne correspond pas à ce que je recherche. Par contre, ton code étant trop compliqué pour moi (beaucoup de notions que je ne connais pas), il ne me semble pas possible de pouvoir le modifier sans ton aide.
Le code proposé est facilement modifiable car il se prête bien à la "modularisation" : il suffit de ne pas afficher le résultat brut fourni par le tableau w. Une petite fonction de mise forme comme celle-là fera (peut-être) l'affaire :​
VB:
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
Il n'y a plus qu'à remplacer les lignes​
VB:
    .Resize(c + 1, c + 1).Value = w
    .Offset(1, 1).Resize(c, c).NumberFormat = "#0.0%"
par :
VB:
    .Resize(c, c + 1).Value = Classement(w)
Si on veut éliminer les valeurs nulles, remplacer​
VB:
          w(i + 1, j + 1) = n / v(i, 1)
          w(j + 1, i + 1) = m / v(j, 1)
par :
VB:
          If n Then w(i + 1, j + 1) = n / v(i, 1)
          If m Then w(j + 1, i + 1) = m / v(j, 1)

Pour être encore plus souple, on peut découper encore davantage avec ce code :​
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")) 'le comptage est effectué par une fonction auxiliaire 
'
    On Error GoTo E2 'pour le cas où il n'existerait pas de feuille nommée "Onglet 4" 
    With Worksheets("Onglet 4").[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), w(1) + 1).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)
Dim i&, j&, k&, l&, c&, d&, m&, n&, s$, v(), w()
Dim sd As New Scripting.Dictionary, rk(), ri(), qk(), qi()
'
  With Feuille.[A1] '
    c = .End(xlToRight).Column 'compte les colonnes de données
    c = -c * (c < .Parent.Columns.Count) 'c=0 si moins de deux colonnes
    ReDim w(c, c) 'dimensionne le tableau de résultats
    If c Then '
      ReDim v(0 To c - 1, 1) 'tableau annexe
      For i = 0 To c - 1 'pour chaque colonne...
        w(i + 1, 0) = .Offset(, i).Value: w(0, i + 1) = .Offset(, i).Value '...relève l'intitulé de la colonne
        d = .Offset(, i).End(xlDown).Row '...compte le nombre de lignes utiles
        d = -d * (d < .Parent.Rows.Count) 'd=0 si aucune ligne utile
        For j = 1 To d - 1 'relève et compte les items de la colonne (dictionnaire temporaire)
          s = CStr(.Offset(j, i).Value) '
          If sd.Exists(s) Then sd(s) = 1 + sd(s) Else sd.Add s, 1& '
        Next '
        v(i, 1) = d - 1 'tableau annexe : colonne 1=nb. d'items
        Set v(i, 0) = sd 'tableau annexe : colonne 0=dictionnaire des items
        Set sd = Nothing 'réinitialise le dictionnaire temporaire
      Next '
      For i = 0 To c - 2 'comparaison deux-à-deux des dictionnaires
        rk = v(i, 0).Keys: ri = v(i, 0).Items '
        For j = i + 1 To c - 1 '
          qk = v(j, 0).Keys: qi = v(j, 0).Items '
          For k = 0 To v(i, 0).Count - 1 '
            For l = 0 To v(j, 0).Count - 1 '
              If qk(l) = rk(k) Then n = n + ri(k): m = m + qi(l) 'compte les items communs
            Next '
          Next '
          If n Then w(i + 1, j + 1) = n / v(i, 1)  'calcul du taux d'items de la colonne j dans la colonne i
          If m Then w(j + 1, i + 1) = m / v(j, 1)  'calcul du taux d'items de la colonne i dans la colonne j
          n = 0: m = 0 'réinitialise les compteurs
        Next '
      Next '
    End If '
  End With
'
  Comptage = Array(w, c)

End Function
La procédure tutu appelle la fonction Comptage qui renvoie un tableau (Array(w, c)) dont le premier élément (w(0)) est un tableau de synthèse carré et dont le deuxième élément (w(1)) est la dimension de ce tableau carré.

La procédure tutu appelle ensuite la fonction Classement en lui passant le tableau w(0) en argument. À partir de ce tableau la fonction construit et renvoie un tableau plus conforme à votre souhait.

Voir dans l'Onglet 4 le résultat obtenu avec la procédure tutu.

Quant à la complication du code, elle ne me semble pas évidente. Je n'utilise guère que des boucles et quelques dictionnaires. Ce sont les mêmes ingrédients que ceux de Grand Chaman Excel, que je salue au passage.​


Bon courage.


ℝOGER2327
#7227


Vendredi 13 Clinamen 141 (Nativité de Maldoror, corsaire aux cheveux d’or - fête Suprême Quarte)
15 Germinal An CCXXII, 7,0069h - abeille
2014-W14-5T16:49:00Z
 

Pièces jointes

  • Capture7.JPG
    Capture7.JPG
    32.6 KB · Affichages: 62
  • exemple code_1-2.xls
    91 KB · Affichages: 63
  • exemple code_1-2.xls
    91 KB · Affichages: 63
  • exemple code_1-2.xls
    91 KB · Affichages: 64

ROGER2327

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

Suite...


Une version un poil plus rapide de la fonction Comptage :​
VB:
Private Function Comptage(Feuille As Worksheet)
Dim i&, j&, k&, l&, c&, d&, m&, n&, s$, u(), v(), w()
Dim sd As New Scripting.Dictionary, rk(), ri(), qk(), qi()

  With Feuille.[A1]

    u = .CurrentRegion.Resize(.CurrentRegion.Rows.Count + 1).Value
    c = UBound(u, 2)
    ReDim w(c, c)
    ReDim v(1 To c, 1)
    For i = 1 To c
      w(i, 0) = u(1, i): w(0, i) = u(1, i)
      d = 1
      Do Until IsEmpty(u(d + 1, i))
        d = d + 1
        s = CStr(u(d, i))
        If sd.Exists(s) Then sd(s) = 1 + sd(s) Else sd.Add s, 1&
      Loop
      v(i, 1) = d - 1
      Set v(i, 0) = sd
      Set sd = Nothing
    Next
    Erase u

    For i = 1 To c - 1
      rk = v(i, 0).Keys: ri = v(i, 0).Items
      For j = i + 1 To c
        qk = v(j, 0).Keys: qi = v(j, 0).Items
        For k = 0 To v(i, 0).Count - 1
          For l = 0 To v(j, 0).Count - 1
            If qk(l) = rk(k) Then n = n + ri(k): m = m + qi(l)
          Next
        Next
        If n Then w(i, j) = n / v(i, 1)
        If m Then w(j, i) = m / v(j, 1)
        n = 0: m = 0
      Next
    Next

  End With

  Comptage = Array(w, c)

End Function


ℝOGER2327
#7229


Samedi 14 Clinamen 141 (Sortie d’Albrecht Dürer, hermétiste - fête Suprême Quarte)
16 Germinal An CCXXII, 9,5046h - laitue
2014-W14-6T22:48:39Z
 

TgR

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

Salut,

Ta macro est vraiment super. Rapide et permet le tri des données ensuite (chose qu'il était impossible de faire correctement avec ma macro). Et bien j'ai encore beaucoup de boulot avant de produire des macro correctes ! J'ai débuté il y a peu la programmation, c'est vraiment passionnant mais pas toujours facile ^^.

Merci pour votre aide !
 

Discussions similaires

Statistiques des forums

Discussions
314 651
Messages
2 111 557
Membres
111 201
dernier inscrit
netcam