XL 2010 Une aide sur "Scripting.Dictionary"

néné06

néné06

XLDnaute Accro
Bonjour le Forum,

Je vous demande une petite aide, car je n'arrive pas à afficher en colonne 11, la valeur ecrite en colonne 8 avant ("-") et en colonne 13, la valeur de la semaine du jour ecrit en colonne 7 qui a été calculée et qui figure en colonne 8 après ("-").
voir la PJ

Merci d'avance!

René
 

Pièces jointes

  • globaleex.xls
    55 KB · Affichages: 59
Trier par date Trier par votes
T

thebenoit59

XLDnaute Accro
Re : Une aide sur "Scripting.Dictionary"

Bonjour René.

Une première idée, sans vouloir trop toucher à ton travail.

Code: 
Public Sub Suite_traitement()
With Sheets("global 2016")
Set mondico = CreateObject("Scripting.Dictionary")
     For Each c In .Range("B6", .[B65000].End(xlUp))
        If c <> "" Then
            temp = c & " -    " & NSem(c.Offset(, 5)) 'designation à rechercher
                If (mondico.exists(temp)) Then
                    mondico(temp) = mondico(temp) + 1
                    Else: mondico(temp) = 1
                End If
            End If
        Next c
    .Cells(6, 8).Resize(mondico.Count).Value = Application.Transpose(mondico.keys) 'ecriture en col 8 la col 2 et col semaine de col 7
    .Cells(6, 9).Resize(mondico.Count).Value = Application.Transpose(mondico.items) 'ecriture en col 9 le nb de repetition du même nom dans la même semaine
    t = Application.Transpose(mondico.keys)
        For i = LBound(t) To UBound(t)
            .Cells(5 + i, "K").Resize(, 2).Value = Split(Replace(t(i, 1), " ", ""), "-")
            .Cells(5 + i, "L").Value = CDbl(.Cells(5 + i, "L").Value)
        Next i
End With
End Sub
 
Vote positif 0 Vote négatif
Paf

Paf

XLDnaute Barbatruc
Re : Une aide sur "Scripting.Dictionary"

Bonjour néné06, thebenoit59,

une approche un peu similaire , mais comme c'est fait ... :

en fin de macro rajouter:
Code: 
    Dim Montab
    ReDim Montab(mondico.Count, 3)
    For Each clé In mondico.keys
        x = x + 1
        Valeurs = Split(clé, " -    ")
        Montab(x, 1) = Valeurs(0)
        Montab(x, 3) = Valeurs(1)
    Next
    Sheets("global 2016").Cells(6, 11).Resize(UBound(Montab), 3) = Montab

A+
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Une aide sur "Scripting.Dictionary"

Bonjour à tous

J'y vais de ma proposition
VB: 
Public Sub Suite_traitement()
     Dim T() As Variant, Kys As Variant
     Dim c As Range, numsem As Long, temp As Variant
     Dim i As Long, mondico As Object
     
     Set mondico = CreateObject("Scripting.Dictionary")
        For Each c In Range("B6", [B65000].End(xlUp))
            If c <> "" Then
                numsem = NSem(c.Offset(, 5))
                temp = c & " -    " & numsem 'designation à rechercher
                mondico(temp) = mondico(temp) + 1
            End If
        Next c
    ReDim T(1 To mondico.Count, 1 To 5)
    For Each Kys In mondico.Keys
        i = i + 1
        temp = Split(Kys, "-")
        T(i, 1) = Kys
        T(i, 2) = mondico(Kys)
        T(i, 4) = Trim(temp(0))
        T(i, 5) = Trim(temp(1))
    Next Kys
    Sheets("global 2016").Cells(6, 8).Resize(UBound(T, 1), UBound(T, 2)) = T
End Sub

Cordialement
 
Vote positif 0 Vote négatif
klin89

klin89

XLDnaute Accro
Re : Une aide sur "Scripting.Dictionary"

Bonsoir le fil, :)

En m'appuyant sur les différentes réponses :

VB: 
Public Sub Suite_traitement()
Dim c As Range, numsem As Long, temp As Variant
Dim mondico As Object, w()
    Set mondico = CreateObject("Scripting.Dictionary")
    mondico.CompareMode = 1
    For Each c In Range("B6", [B65000].End(xlUp))
        If c <> "" Then
            numsem = NSem(c.Offset(, 5))
            temp = c & " -    " & numsem     'designation à rechercher
            If Not mondico.exists(temp) Then
                mondico(temp) = VBA.Array(temp, 1, Empty, c.Value, numsem)
            Else
                w = mondico(temp)
                w(1) = w(1) + 1
                mondico(temp) = w
            End If
        End If
    Next c
    Sheets("global 2016").Cells(6, 8).Resize(mondico.Count, 5).Value = _
    Application.Transpose(Application.Transpose(mondico.items))
End Sub
klin89
 
Dernière édition:
Vote positif 0 Vote négatif
néné06

néné06

XLDnaute Accro
Re : Une aide sur "Scripting.Dictionary"

Bonjour Klin89, le forum

@klin
j'ai regardé ton code et l'analyse du problème est plus optimisée!
L' instruction "If Not mondico.exists" change mon analyse du départ et est meilleure.

Merci!

René
 
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Une aide sur "Scripting.Dictionary"

Bonjour à tous, le fil, le forum
A ce moment là, autant gagner un maximum de temps (plus du for each c) et se passer de transpose:
VB: 
Public Sub Suite_traitement()
Dim numsem&, i&, temp$
Dim T() As Variant, mondico As Object
Set mondico = CreateObject("Scripting.Dictionary")
T = Range("B6", [B65000].End(xlUp)(1, 6))
For i = LBound(T, 1) To UBound(T, 1)
    If T(i, 1) <> "" Then
        numsem = NSem(CDate(T(i, 6)))
        temp = T(i, 1) & " -    " & numsem
        If Not mondico.exists(temp) Then
            mondico(temp) = mondico.Count + 1
            T(mondico(temp), 4) = T(i, 1)
            T(mondico(temp), 1) = temp
            T(mondico(temp), 3) = ""
            T(mondico(temp), 5) = numsem
        End If
        T(mondico(temp), 2) = T(mondico(temp), 2) + 1
    End If
Next i
Sheets("global 2016").Cells(6, 8).Resize(mondico.Count, 5) = T
End Sub
Cordialement
 
Dernière édition:
Vote positif 0 Vote négatif
Efgé

Efgé

XLDnaute Barbatruc
Re : Une aide sur "Scripting.Dictionary"

Re
Un oubli dans le code, au cas où.....
VB: 
Public Sub Suite_traitement()
Dim numsem&, i&, temp$
Dim T() As Variant, mondico As Object
Set mondico = CreateObject("Scripting.Dictionary")
T = Range("B6", [B65000].End(xlUp)(1, 6))
For i = LBound(T, 1) To UBound(T, 1)
    If T(i, 1) <> "" Then
        numsem = NSem(CDate(T(i, 6)))
        temp = T(i, 1) & " -    " & numsem
        If Not mondico.exists(temp) Then
            mondico(temp) = mondico.Count + 1
            T(mondico(temp), 4) = T(i, 1)
            T(mondico(temp), 1) = temp
            T(mondico(temp), 2) = 0
            T(mondico(temp), 3) = ""
            T(mondico(temp), 5) = numsem
        End If
        T(mondico(temp), 2) = T(mondico(temp), 2) + 1
    End If
Next i
Sheets("global 2016").Cells(6, 8).Resize(mondico.Count, 5) = T
End Sub
Cordialement
 
Vote positif 0 Vote négatif

Discussions similaires

hypo78
  • Question
XL 2016 Récupérer données sur plusieurs feuilles
2
Réponses
18
Affichages
601
Lolote83
L
J
  • Question
XL 2021 Classement avec ex aequo parfait
Réponses
3
Affichages
183
Jul1en
J
L
  • Résolu(e)
Power Query Aide pour dépoviter
Réponses
7
Affichages
301
Cousinhub
Cousinhub
Yuby
  • Question
XL 2016 Mise en forme conditionnelle pour une date dépassée de 3 ans par rapport à une autre date
Réponses
1
Affichages
270
JHA
J
L
  • Question
VBA : erreur sur boucle
Réponses
2
Affichages
84
Latias
L
C
  • Question
XL 2013 Userform ne fonctionne pas s'il manque des Numéros de liste
Réponses
9
Affichages
338
candido57
C
petitbuzuc
  • Question
XL 2016 Aide pour maj auto de la date + selection multiple dans une liste déroulante
Réponses
5
Affichages
241
fanch55
fanch55
L
  • Résolu(e)
Power Query PowerQuery - Recherche dans une colonne
Réponses
2
Affichages
252
Labud
L
P
  • Résolu(e)
Microsoft 365 recherche heure dans une plage horaire
Réponses
12
Affichages
307
TooFatBoy
TooFatBoy
L
  • Résolu(e)
XL 2019 Renvoyer une valeur colonne A avec la dernière valeur de la colonne B
Réponses
5
Affichages
286
Gégé-45550
Gégé-45550

Membres actuellement en ligne

9 membres et 70 invités.

Partager cette page

Tutos vidéos

Power Query : Ajouter des requêtes (Excel et Power BI)
Créez votre première fonction LAMBDA dans Excel en 3 étapes!
LAMBDA, l’arme secrète de Microsoft pour Excel !
Office Insider - Découvrez les nouveautés Excel avant tout le monde

Statistiques des forums

Discussions
312 336
Messages
2 087 388
Membres
103 534
dernier inscrit
Kalamymustapha