VBA aide scripting-dictionary

Bonjour a toutes et a tous,

J'aimerais faire un Pareto (courbe ABC) automatiquement via VBA pour cela j'ai trouver un tableau dynamique sur le net (qui n'est pas présent sur le doc cijoint) mais il me faut pour cela copier

La cellule de la colonne B et C qui correspond a la cellule de la colonne AI quand AI et différent de vide et inférieur à 1 (100%) de la feuille listing machine

Le tout serais coller dans une autre feuille (Graph) et si possible du plus petit au plus grand (mais ça à la limite avec un filtre sa se fera sans vba).

J'ai un exemple ici:

Option Explicit

' constantes à modifier selon ta configuration
' Feuille Source
Const FS = "Listing-machine"
Const lidebFS = 8
Const comacFS = "C"
Const comacFS1 = "B"
Const comacFS2 = "AI"

Const coerrFS = "AI"
' Feuille But
Const FB = "Graph"
Const celdebFB = "A20"
Const celdebFB1 = "b20"
Const celdebFB2 = "c20"

Dim cptr As Long
' message recherché

Const s As Integer = "0"

Public Sub Pareto()
Dim liFS As Long, lifinFS As Long
Dim liFS1 As Long, lifinFS1 As Long
Dim liFS2 As Long, lifinFS2 As Long

Dim dico, dico1, dico2 As Object, cle, cle1, cle2 As String, cles, cles1, cles2, nbcles As Long
' dictionnaire des machines en erreur

Set dico = CreateObject("scripting.dictionary")
Set dico1 = CreateObject("scripting.dictionary")
Set dico2 = CreateObject("scripting.dictionary")

With Sheets(FS)

  lifinFS = .Range(comacFS & Rows.Count).End(xlUp).Row

  For liFS = lidebFS To lifinFS

    cptr = cptr + 1

    If .Range(coerrFS & liFS).Value > s And .Range(coerrFS & liFS).Value < 1 Then
'   If s <> .Range(coerrFS & liFS).Value And s <> 0 Then
  '  If s = .Range(coerrFS & liFS).Value Then

      cle = .Range(comacFS & liFS).Value
      cle1 = .Range(comacFS1 & liFS).Value
      cle2 = .Range(comacFS2 & liFS).Value

      'if cle == "" MsgBox('Clé vide ligne '. Afficher ligne et Colonne d'erreur .)
      If (IsEmpty(cle)) Then MsgBox "Vide 1 : Ligne" & liFS & "Colonne " & comacFS
      If (IsEmpty(cle1)) Then MsgBox "Vide 2 : Ligne" & liFS & "Colonne " & comacFS1
      If (IsEmpty(cle2)) Then MsgBox "Vide 3 : Ligne" & liFS & "Colonne " & comacFS2

      If (Not dico.exists(cle)) Then dico.Add cle, 1
      If (Not dico1.exists(cle1)) Then dico1.Add cle1, 1
      If (Not dico2.exists(cle2)) Then dico2.Add cle2, 1

    End If

  Next liFS

End With

nbcles = dico.Count

cles = dico.keys
cles1 = dico1.keys
cles2 = dico2.keys

' resultat
With Sheets(FB)

  .Range(celdebFB).Resize(1000, 1).ClearContents
  .Range(celdebFB).Offset(-1, 0).Value = "Désignation"
  .Range(celdebFB).Resize(nbcles, 1) = Application.Transpose(cles)

  .Range(celdebFB1).Resize(1000, 1).ClearContents
  .Range(celdebFB1).Offset(-1, 0).Value = "N°Machine"
  .Range(celdebFB1).Resize(nbcles, 1) = Application.Transpose(cles1)

  .Range(celdebFB2).Resize(1000, 1).ClearContents
  .Range(celdebFB2).Offset(-1, 0).Value = "DI"
  .Range(celdebFB2).Resize(nbcles, 1) = Application.Transpose(cles2)

End With

End Sub

Mon code me donne quelque chose d'assez étrange puisque mes cles: cles et cles1 fonctionne parfaitement, cependant ma cles2 elle me pose des soucis, les premières données sont exactes, puis une sorte de décalage (non constant ni proportionnel) se fait dans les valeurs.

J'ai également une valeur à 6340111773822,38 a la place de 6.34% mais encore une fois décalé. Ainsi que des #N/A en fin de tableau.

Depuis la création du fichier ci-joint j'ai dé-fusionné et supprimé certaines lignes qui porter a confusion (Celles de: Moy / UP. dans listing-machine).

Je tiens à vous remercier d'avoir lu jusqu'ici et a me demander pardon pour mon code VBA mais c'est la première fois que j'en fait.

Bonjour,

Pareto et moi on n'est pas copain, donc je n'ai même pas regardé ton fichier mais...

Les déclarations collectives ça n'existe pas sous cette forme en VBA :

Dim dico, dico1, dico2 As Object, cle, cle1, cle2 As String, cles, cles1, cles2, nbcles As Long

Il faut typer chaque variable individuellement mais je ne suis pas persuadé que As Object convienne pour un dico.

Puisque dico et dico1 fonctionnent correctement, je ferai de même pour dico2 (donc tu supprime le As Object.

Il en va de même pour clé2 qui est la seule typée. ou tu vires le As String ou tu mets du As String à tout le monde : Je ne sais pas trop !

Moi par exception pour tout ce qui concerne les dico je ne type pas mes variables. : Je laisse VBA se débrouiller tout seul : il se débrouille d'ailleurs en général très bien...

A+

Bonjour et merci de la rapidité de la réponse, je ne suis pas sur d'avoir compris ce que je devais faire mais si c'est cela, ça n'a rien changer pour moi.

Dim dico
Dim dico1
Dim dico2

Dim cle
Dim cle1
Dim cle2

Dim nbcles
Dim cles
Dim cles1
Dim cles2

Edit je pense que le problème vient de là:

 If (Not dico.exists(cle)) Then dico.Add cle, 1
      If (Not dico1.exists(cle1)) Then dico1.Add cle1, 1
      If (Not dico2.exists(cle2)) Then dico2.Add cle2, 1

Et plus exactement ici:

    If (Not dico2.exists(cle2)) Then dico2.Add cle2, 1

J'aimerais pouvoir faire

If (Not dico.exists(cle)) Then dico.Add cle, 1 AND dico1.Add cle1, 1 AND dico2.Add cle2, 1 

Mais sa ne marche pas, si vous pouvez m'indiquer la syntaxe sa serais génial.

bonjour,

Peut-être :

If Not dico.exists(cle) Then 
dico.Add cle, 1 
dico1.Add cle1, 1 
dico2.Add cle2, 1
End if 

Juste sur le plan syntaxique hein !

Après, sur le plan algorithmique, je suis complètement largué...

A+

Bonjour,

J'ai déjà essayer mais malheureusement cela ne fonctionne pas.

Bonjour,

moi j'ai osé ouvrir ton fichier.

3 modules et ... pas un seul avec ton code.

Refermé aussitôt. Quand on veut de l'aide on met un fichier débarrassé de l'inutile (réduit à l'essentiel pour la question) et en situation.

eric

eriiic a écrit :

Bonjour,

moi j'ai osé ouvrir ton fichier.

3 modules et ... pas un seul avec ton code.

Refermé aussitôt. Quand on veut de l'aide on met un fichier débarrassé de l'inutile (réduit à l'essentiel pour la question) et en situation.

eric

Comme trop souvent...

Bonjour à tous,

En effet pas facile de s'y retrouver

En résumé, feuille "Listing-machine", on détermine les clés du dictionnaire en s'appuyant sur les données de la colonne 1,

les 2 moyennes seront calculées en se basant sur les données des colonnes 35 et 36.

Un essai :

Restitution dans la feuille"Graph"

Option Explicit
Sub test2()
Dim a, b(), w(), e, i As Long, n As Long
    With Sheets("Listing-machine").Range("a7:ij122")
        a = .Value
        With CreateObject("Scripting.Dictionary")
            .CompareMode = 1
            For i = 2 To UBound(a, 1)
                If Left(a(i, 1), 3) <> "Moy" Then
                    If IsEmpty(a(i, 1)) Then a(i, 1) = a(i - 1, 1)
                    'clé colonne 1
                    If Not .exists(a(i, 1)) Then
                        .Item(a(i, 1)) = VBA.Array(a(i, 1), Empty, Empty, Empty, Empty, Empty, Empty)
                    End If
                    w = .Item(a(i, 1))
                    'cumul colonne 35
                    If IsNumeric(a(i, 35)) Then
                        w(1) = w(1) + a(i, 35)
                        w(2) = w(2) + 1
                    End If
                    'cumul colonne 36
                    If IsNumeric(a(i, 36)) Then
                        w(4) = w(4) + a(i, 36)
                        w(5) = w(5) + 1
                    End If
                    .Item(a(i, 1)) = w
                End If
            Next
            For Each e In .keys
                w = .Item(e)
                'calcul des 2 moyennes
                w(3) = w(1) / w(2)
                w(6) = w(4) / w(5)
                .Item(e) = w
            Next
            'affectation dans la variable b
            'des 3 éléménts retenus
            'soit l'intitulé des secteurs et les 2 moyennes
            ReDim b(1 To .Count + 1, 1 To 3)
            n = 1
            b(n, 1) = "DESI1": b(n, 2) = "Global": b(n, 3) = "Critique"
            For i = 0 To .Count - 1
                n = n + 1
                b(n, 1) = .items()(i)(0) 'les secteurs
                b(n, 2) = .items()(i)(3) 'la moyenne globale
                b(n, 3) = .items()(i)(6) 'la moyenne critique
            Next
            'restitution dans la feuille "Graph"
            With Sheets("Graph").Range("a1")
                .CurrentRegion.Clear
                With .Resize(UBound(b, 1), UBound(b, 2))
                    .Value = b
                    .Columns("b:c").NumberFormat = "0.00%"
                End With
            End With
        End With
    End With
End Sub

klin89

A supprimer

A supprimer

Bonjour et merci de vos réponse,

Je n'ai pas accès au fichier ce week-end mais j'en referais un dès que possible, et désolé du fichier vide enfin sans module.

En réalité je souhaite récupéré dans la feuille graph le nom de la machine son numéro xx_xx ainsi que sa disponibilité en AJ présent dans la feuille listing machine.

Dans le module 2, le code "d'origine" mentionné en début de topic, et la retranscription du code dans l'onglet Graph.

Edit:

@Klin89 Ce n'est pas ce que je cherchez mais j'aurais eu à le faire puisque j'ai du supprimer les moyennes des UP pour ne pas les faire apparaître dans mon pareto. Ton travail ne sera pas vain

UP Après vérification des règles