[RESOLU] Différence entre : Item et Add avec CreateObject("Scripting.Dictionary")

laurent950

XLDnaute Accro
Bonsoir le fils et le forum,

je découvre vos module VBA (Dictionnaire)

‘ Si je crée un dictionnaire MONDICO (comme dans l’exemple)

Set Mondico = CreateObject("Scripting.Dictionary") (soit Mondico le dictionaire crée)

‘ =====================================================

Pour remplis ce dictionnaire Qu’elle est la différence entre : Item et Add

- Mondico.Item(Cells(1,1) & Cells (1, 2)) = Mondico .Item(Cells(1,1) & Cells (1, 2))

- Mondico.Add Cells(1,1) & Cells (1, 2)) , Cells(1,1) & Cells (1, 2))

‘ =====================================================

Pour vider ce dictionnaire Qu’elle est la différence entre : Removeall et Nothing

- Mondico.Removeall

- set Mondico = Nothing

‘ =====================================================
.
Merci par avance

Laurent
 
Dernière édition:

CISCO

XLDnaute Barbatruc
Bonjour

Merci Dranreb et Viard. Je cherche juste à bien comprendre. Et d'ailleurs, la doc pdf fournie par Viard m'aide bien pour cela. La phrase "Proche des tableaux, l'objet dictionnaire peut aussi être utile dans certains cas. Il s'agit d'un tableau à deux colonnes..." résume bien ce que je cherchais. Certaines documentations démarrent en indiquant qu'on n'a pas d'indice dans les dictionnaires, mais des keys... En écrivant "Il s'agit d'un tableau à deux colonnes, les éléments de la première colonne étant appelés des clés... Il permet d'accéder directement à l'élément (item placé dans la seconde colonne) associé à une clé (key placée dans la première colonne) sans avoir à balayer les champs à la recherche de la clé.", cela me semble plus simple...

Encore merci pour cette doc pleine de petits codes montrant bien de quoi on parle. Me reste plus qu'à fouiller dans les fichiers mis en pièce jointe.

Au plaisir.

@ plus
 

cathodique

XLDnaute Barbatruc
Bonjour tout le monde,:)

Excusez mon intrusion, ça m'intéresse tellement que j'ai pu m'empêcher de mettre mon grain de sel.

@Misange: Il y a de cela un bon moment que j'avais trouvé ton tuto. Novice à ce moment, je ne m'y étais pas trop tardé. Je le regrette aujourd'hui, hélas je ne l'ai pas sauvegardé.

En trouvant tes liens, j'avais cru que le site est à nouveau opérationnel. Toujours pas le cas.
Ce qui veut dire que tes liens nous mènent vers des pages vides.
ou plutôt vers ceci Oups ! Cette page est introuvable.
Aurais-tu sous la main ces tutos et les mettre en ligne sur ce site? ça serait très gentil de ta part.;)


Bonne journée à toutes et à tous.
 

Dranreb

XLDnaute Barbatruc
Il me semble que dire qu'un Dictionary est un tableau à 2 colonnes peut induire en erreur dans la mesure où ça peut donner l'impression que cette représentation y est disponible en permanence, alors qu'il sait seulement reconstituer sur demande une table des clés ou des items, ce qui est assez long. Je pense qu'il vaut mieux le voir comme un ensemble analogue à une table à une dimension, mais dont les indices, alors appelés clés, peuvent être autre chose que des entiers.
L'analogie est même plus éloignée de la réalité que pour une Collection, dont un membre peut toujours être atteint soit selon sa position dans la collection, soit selon une clé String. Mais une collection ne peut restituer de clé, on est obligé pour cela de la stocker dans chaque membre.
 
Dernière édition:

CISCO

XLDnaute Barbatruc
Bonjour

Bonjour

" l'objet dictionnaire peut aussi être utile dans certains cas. Il s'agit d'un tableau à deux colonnes..."

Consternant!

BISSON

Ce n'est qu'une analogie. Mais bon, il faut bien admettre qu'il y a parfois des problèmes de langage pour expliquer les formules ou les concepts en VBA, entre les tableaux sur les feuilles, les tableaux VBA, les matrices... C'est parfois plus simple d'utiliser des raccourcis (qui doivent faire peur aux puristes en français) ou des images peu précises. Il ne faut pas s'en offusquer pour autant.

@ plus

P.S : Pour ce qui est des dictionnaires, il faudrait peut être plutôt écrire "Il s'agit d'un tableau virtuel de deux lignes de paires clef (la première ligne) - item (la seconde ligne) fonctionnant sans indice (mais directement avec la clef, forcément unique), d'où gain de temps" ?
 
Dernière édition:

CISCO

XLDnaute Barbatruc
Bonjour

Le début de la présentation de Misange au sujet des dictionnaires VBA sur le lien donné ci-dessus par JCGL (plus exactement),

Scripting.dictionary est un outil VBA qui stocke en mémoire vive une liste de paires d'éléments (clé,élément).
key1, item1
key2, item2
key3, item3


@ plus
 
Dernière édition:

laurent950

XLDnaute Accro
Bonsoir complément.

Redim Preserve un dictonary
a = dico.keys : b = dico.items
ReDim tabor(UBound(a), 1 To 5) ' Une dimenssion , plusieurs colonne pour "tabor"
For n = LBound(a) To UBound(a)

Dictonary associer avec des Array 2 D

suite à un Fils avec divers explication de cette objet :

C'est résolu... Le Numéro de l'item créer par incrementation si la clef n'existe pas !
Explication ci-dessous + lien avec Fils ci-dessus (avec divers exemple)

L'indice Items que je rechercher était ici .
Dim NuméroItem As New Scripting.Dictionary
Dim d As New Scripting.Dictionary
Set d = New Dictionary

' ***************************************************************************************
If d.Exists(Clef) Then
cpt = NuméroItem (Clef) ' Clef, Item / Si existe renvois la position dans le dictionnaire)
Else
cpt = d.Count + 1 ' Création des numéros (Icrémentation = pour remplir un tableau)
NuméroItem (Clef) = cpt ' Clef, Item
End If
' ***************************************************************************************
une autres variante
VB:
Sub essaiLaurent950_Test778suite()
Dim TI As Single
    TI = Timer
Dim d As New Scripting.Dictionary
    d.CompareMode = TextCompare
Dim Tb() As Variant
    Tb = Range("a1").CurrentRegion
Dim i, cpt As Double
Dim x As Variant
' ****************************************************************************************************
    For i = LBound(Tb) + 1 To UBound(Tb)
        If d.Exists(Tb(i, 2) & "|" & Tb(i, 3)) Then
            x = d(Tb(i, 2) & "|" & Tb(i, 3))
            d(Tb(i, 2) & "|" & Tb(i, 3)) = Array(Tb(cpt + 1, 2), Tb(cpt + 1, 3), Tb(x(3), 16) + Tb(i, 16), x(3))
        Else
            cpt = d.Count + 1
            d.Add Tb(i, 2) & "|" & Tb(i, 3), Array(Tb(cpt + 1, 2), Tb(cpt + 1, 3), Tb(cpt + 1, 16), cpt + 1)
        End If
    Next i
' ****************************************************************************************************
[v1].Resize(d.Count + 1, 3) = Application.Transpose(Application.Transpose(d.Items)) ' = OK

MsgBox Format(Timer - TI, "0.000\ sec.")
End Sub
'*************************************************************************************************
VB:
Sub essaiLaurent950_Test77Bis()
Dim TI As Single
    TI = Timer
Dim d As New Scripting.Dictionary
    Set d = New Dictionary
    d.CompareMode = TextCompare
Dim NumItem As New Scripting.Dictionary
    Set NumItem = New Dictionary
Dim Tb() As Variant
    Tb = Range("a1").CurrentRegion
Dim i, cpt As Double
' ****************************************************************************************************
Dim Ar As Variant
Dim x As Variant
    For i = LBound(Tb) + 1 To UBound(Tb)
        If d.Exists(Tb(i, 2) & "|" & Tb(i, 3)) Then
            cpt = NumItem(Tb(i, 2) & "|" & Tb(i, 3))
            d(Tb(i, 2) & "|" & Tb(i, 3)) = Array(Tb(cpt + 1, 2), Tb(cpt + 1, 3), Tb(cpt + 1, 16) + Tb(i, 16))
        Else
            cpt = d.Count + 1
            NumItem(Tb(i, 2) & "|" & Tb(i, 3)) = cpt
            d.Add Tb(i, 2) & "|" & Tb(i, 3), Array(Tb(cpt + 1, 2), Tb(cpt + 1, 3), Tb(cpt + 1, 16))
        End If
    Next i
' ****************************************************************************************************
[v1].Resize(d.Count + 1, 3) = Application.Transpose(Application.Transpose(d.Items)) ' = OK

MsgBox Format(Timer - TI, "0.000\ sec.")
End Sub
' ****************************************************************************************************
une variante :
VB:
Sub essaiLaurent950_Test779suite()
Dim TI As Single
    TI = Timer
Dim d As New Scripting.Dictionary
    d.CompareMode = TextCompare
Dim Tb() As Variant
    Tb = Range("a1").CurrentRegion
Dim i, cpt As Double
Dim TabRes() As Variant
ReDim TabRes(1 To 4, 1 To 1)
' ****************************************************************************************************
    For i = LBound(Tb) + 1 To UBound(Tb)
        If d.Exists(Tb(i, 2) & "|" & Tb(i, 3)) Then
            cpt = d(Tb(i, 2) & "|" & Tb(i, 3))
            TabRes(3, cpt) = TabRes(3, cpt) + Tb(i, 16)
        Else
            cpt = d.Count + 1
            d.Add Tb(i, 2) & "|" & Tb(i, 3), cpt
                TabRes(1, cpt) = Tb(i, 2)
                TabRes(2, cpt) = Tb(i, 3)
                TabRes(3, cpt) = Tb(i, 16)
                TabRes(4, cpt) = cpt
            ReDim Preserve TabRes(1 To 4, 1 To (cpt + 1))
        End If
    Next i
[v1].Resize(UBound(TabRes, 2), UBound(TabRes, 1)) = Application.Transpose(TabRes)
MsgBox Format(Timer - TI, "0.000\ sec.")
End Sub
' *****************************************************************************************************
Code de @Dranreb que je consigne ici : le plus rapide.
VB:
Sub EssaiDranreb()
   Dim TDon(), LDon As Long, TRés(), LRés As Long, Clé As String, Dic As New dictionary
   TDon = ActiveSheet.[A1].CurrentRegion.Value
   ReDim TRés(1 To UBound(TDon, 1), 1 To 3)
   For LDon = 1 To UBound(TDon, 1)
      Clé = TDon(LDon, 2) & "|" & TDon(LDon, 3)
      If Dic.exists(Clé) Then
         LRés = Dic(Clé)
         TRés(LRés, 3) = TRés(LRés, 3) + TDon(LDon, 16)
      Else
         LRés = Dic.Count + 1: Dic(Clé) = LRés
         TRés(LRés, 1) = TDon(LDon, 2)
         TRés(LRés, 2) = TDon(LDon, 3)
         TRés(LRés, 3) = TDon(LDon, 16)
         End If
      Next LDon
   ActiveSheet.[V1].Resize(Dic.Count, 3) = TRés
   End Sub
' ******************************************************************************************************
Ce code a Modifier : 2 fois plus long que celui de Dranred
VB:
Code
Sub essaiLaurent950_Test780suite()
Dim Ti As Single
    Ti = Timer
Dim d As New Scripting.Dictionary
    d.CompareMode = TextCompare
Dim Tb() As Variant
    Tb = Range("a1").CurrentRegion
Dim i, cpt As Double
Dim TabRes() As Variant
ReDim TabRes(LBound(Tb) To UBound(Tb), 1 To 3)
' ****************************************************************************************************
    For i = LBound(Tb) + 1 To UBound(Tb)
        If d.Exists(Tb(i, 2) & "|" & Tb(i, 3)) Then
            cpt = d(Tb(i, 2) & "|" & Tb(i, 3))
            TabRes(cpt, 3) = TabRes(cpt, 3) + Tb(i, 16)
        Else
            cpt = d.Count + 1
            d.Add Tb(i, 2) & "|" & Tb(i, 3), cpt
                TabRes(cpt, 1) = Tb(i, 2)
                TabRes(cpt, 2) = Tb(i, 3)
                TabRes(cpt, 3) = Tb(i, 16)
        End If
    Next i
' ****************************************************************************************************
'[v1].Resize(d.Count + 1, 3) = Application.Transpose(Application.Transpose(d.Items)) ' = OK
[V1].Resize(UBound(TabRes, 1), 3) = TabRes
MsgBox Format(Timer - Ti, "0.000\ sec.")
End Sub

Lien Utiles
*je me suis aidé de ces sites : (C'est Important de lire pour comprendre le module de classe)
Scripting.Dictionary










' ******************************************************************************************************
Exemple de Code Dictictionary qui fonctionne pour plusieurs Feuilles
VB:
Option Explicit
Sub essaiLaurent950()
Dim TI As Single: TI = Timer
Dim d As New Scripting.Dictionary
    d.CompareMode = TextCompare
Dim Clef As String
Dim Tb() As Variant
Dim i, cpt As Double
Dim TabRes() As Variant
ReDim TabRes(1 To 5, 1 To 1)
' ****************************************************************************************************
Dim ws As Worksheet
    For Each ws In ActiveWorkbook.Worksheets
        If LCase(ws.Name) = LCase("FEUILLE1") Or _
                                LCase(ws.Name) = LCase("FEUILLE2") Or _
                                        LCase(ws.Name) = LCase("FEUILLE3") Then
            Tb = ws.Range("a1").CurrentRegion
' ****************************************************************************************************
                For i = LBound(Tb) + 1 To UBound(Tb)
                    Clef = Tb(i, 1) & "|" & Tb(i, 1)
                        If d.Exists(Clef) Then
                            cpt = d(Clef)
                            TabRes(3, cpt) = TabRes(3, cpt) + Tb(i, 5)
                            TabRes(4, cpt) = TabRes(4, cpt) + Tb(i, 6)
                            TabRes(5, cpt) = TabRes(5, cpt) + 1
                        Else
                            cpt = d.Count + 1
                            d.Add Clef, cpt
                            TabRes(1, cpt) = Tb(i, 1)
                            TabRes(2, cpt) = Tb(i, 2)
                            TabRes(3, cpt) = Tb(i, 5)
                            TabRes(4, cpt) = Tb(i, 6)
                            TabRes(5, cpt) = 1
                        ReDim Preserve TabRes(1 To 5, 1 To (cpt + 1))
                        End If
                Next i
        End If
' ****************************************************************************************************
    Next ws
[a2].Resize(UBound(TabRes, 2), UBound(TabRes, 1)) = Application.Transpose(TabRes)
MsgBox Format(Timer - TI, "0.000\ sec.")
End Sub
 
Dernière édition:

laurent950

XLDnaute Accro
Bonjour,
Un autres exemple pour moi :
Dictionary = Créer des sous tableaux
Fonction = test sur tableau Multidimension (1D Ou 2D)
VB:
Function NumberOfArrayDimensions(arr As Variant) As Integer
' https://stackoverflow.com/questions/24613101/vba-check-if-array-is-one-dimensional
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' NumberOfArrayDimensions
' This function returns the number of dimensions of an array. An unallocated dynamic array
' has 0 dimensions. This condition can also be tested with IsArrayEmpty.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Ndx As Integer
Dim Res As Integer
On Error Resume Next
' Loop, increasing the dimension index Ndx, until an error occurs.
' An error will occur when Ndx exceeds the number of dimension
' in the array. Return Ndx - 1.
    Do
        Ndx = Ndx + 1
        Res = UBound(arr, Ndx)
    Loop Until Err.Number <> 0
Err.Clear
NumberOfArrayDimensions = Ndx - 1
End Function
Tri = sur tableau 2 D

le code : avec Scripting.Dictionary (Exemple 1)
VB:
Sub DicoTriTransfertLaurent950()
' https://www.excel-downloads.com/threads/transfer-et-trie-dune-feuil-a-une-autre-feuil-meme-classeur.20049927/
Dim TI As Single
'    TI = Timer
' ***************************************************
'Dim d As New Scripting.Dictionary
Dim d As Object
    Set d = CreateObject("Scripting.Dictionary")
    d.CompareMode = TextCompare
Dim cef As String
' ***************************************************
Dim Tb() As Variant
Dim ShF1 As Worksheet
    Set ShF1 = Worksheets("BDD")
    Tb = ShF1.Range(ShF1.Cells(2, 1), ShF1.Cells(ShF1.Cells(65536, 5).End(xlUp).Row, 112))
Dim i, j, cpt As Double
' ***************************************************
Dim tabDico() As Variant
ReDim tabDico(0)
Dim TabRes() As Variant
ReDim TabRes(1 To 8, 1 To 1)
Dim Temp() As Variant
' ***************************************************
Dim a() As Variant
' ***************************************************
Dim ShF2 As Worksheet
    Set ShF2 = Worksheets("TrieparIGC")
    'ShF2.Range(ShF2.Cells(2, 5), ShF2.Cells(ShF2.Cells(65536, 5).End(xlUp).Row + 1, 30)).Interior.Pattern = xlNone
    'ShF2.Range(ShF2.Cells(2, 5), ShF2.Cells(ShF2.Cells(65536, 5).End(xlUp).Row + 1, 30)).ClearContents
' ***************************************************
    For i = LBound(Tb) + 1 To UBound(Tb) ' Commence à la ligne 2 (LBound(Tb) + 1)
        clef = Tb(i, 12)
            If d.Exists(clef) Then
            cpt = d(clef)
            Temp = tabDico(cpt - 1)
            ReDim Preserve Temp(1 To 8, 1 To UBound(Temp, 2) + 1)
            tabDico(cpt - 1) = Temp
                tabDico(cpt - 1)(1, UBound(Temp, 2)) = Tb(i, 4)
                tabDico(cpt - 1)(2, UBound(Temp, 2)) = Tb(i, 5)
                tabDico(cpt - 1)(3, UBound(Temp, 2)) = Tb(i, 6)
                tabDico(cpt - 1)(4, UBound(Temp, 2)) = Tb(i, 18)
                tabDico(cpt - 1)(5, UBound(Temp, 2)) = CDbl(Tb(i, 19))
                tabDico(cpt - 1)(6, UBound(Temp, 2)) = Tb(i, 12)
                tabDico(cpt - 1)(7, UBound(Temp, 2)) = Tb(i, 112)
                tabDico(cpt - 1)(8, UBound(Temp, 2)) = Tb(i, 95)
            Erase Temp
        Else
            cpt = d.Count + 1
            d(clef) = cpt
            tabDico(cpt - 1) = TabRes
                tabDico(cpt - 1)(1, 1) = Tb(i, 4)
                tabDico(cpt - 1)(2, 1) = Tb(i, 5)
                tabDico(cpt - 1)(3, 1) = Tb(i, 6)
                tabDico(cpt - 1)(4, 1) = Tb(i, 18)
                tabDico(cpt - 1)(5, 1) = CDbl(Tb(i, 19))
                tabDico(cpt - 1)(6, 1) = Tb(i, 12)
                tabDico(cpt - 1)(7, 1) = Tb(i, 112)
                tabDico(cpt - 1)(8, 1) = Tb(i, 95)
            ReDim Preserve tabDico((cpt - 1) + 1)
        End If
    Next i
' Suppression de la derniere dimension
    ReDim Preserve tabDico(UBound(tabDico) - 1)
' Boucle sur tabDico
    cpt = 4
    For i = LBound(tabDico) To UBound(tabDico)
        ' Tri des tableaux
            a = Application.Transpose(tabDico(i))
                If NumberOfArrayDimensions(a) = 2 Then
                    Tri a, 5, LBound(a, 1), UBound(a, 1)
                    tabDico(i) = Application.Transpose(a)
                End If
            Erase a
        For j = 1 To 7
            ShF2.Cells(cpt, j + 1).Resize(UBound(tabDico(i), 2), 1) = Application.Index(Application.Transpose(tabDico(i)), , j)
        Next j
            ShF2.Cells(cpt, 12).Resize(UBound(tabDico(i), 2), 1) = Application.Index(Application.Transpose(tabDico(i)), , 8)
    cpt = ShF2.Cells(65536, 2).End(xlUp).Row + 1
    Next i
'MsgBox Format(Timer - TI, "0.000\ sec.")
End Sub

Sub Tri(a(), ColTri, gauc, droi) ' Quick sort
    ref = a((gauc + droi) \ 2, ColTri)
    g = gauc: d = droi
    Do
      Do While a(g, ColTri) < ref: g = g + 1: Loop
      Do While ref < a(d, ColTri): d = d - 1: Loop
        If g <= d Then
           For k = LBound(a, 2) To UBound(a, 2)
             Temp = a(g, k): a(g, k) = a(d, k): a(d, k) = Temp
           Next k
           g = g + 1: d = d - 1
        End If
    Loop While g <= d
        If g < droi Then Call Tri(a, ColTri, g, droi)
        If gauc < d Then Call Tri(a, ColTri, gauc, d)
End Sub

Function NumberOfArrayDimensions(arr As Variant) As Integer
' https://stackoverflow.com/questions/24613101/vba-check-if-array-is-one-dimensional
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' NumberOfArrayDimensions
' This function returns the number of dimensions of an array. An unallocated dynamic array
' has 0 dimensions. This condition can also be tested with IsArrayEmpty.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Ndx As Integer
Dim Res As Integer
On Error Resume Next
' Loop, increasing the dimension index Ndx, until an error occurs.
' An error will occur when Ndx exceeds the number of dimension
' in the array. Return Ndx - 1.
    Do
        Ndx = Ndx + 1
        Res = UBound(arr, Ndx)
    Loop Until Err.Number <> 0
Err.Clear
NumberOfArrayDimensions = Ndx - 1
End Function

* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

le code : avec Scripting.Dictionary (Exemple 1 Bis)

VB:
Sub DicoTriTransfertLaurent950_Bis()
' https://www.excel-downloads.com/threads/transfer-et-trie-dune-feuil-a-une-autre-feuil-meme-classeur.20049927/
Dim TI As Single
    TI = Timer
' ***************************************************
Dim cef As String
' ***************************************************
Dim Tb() As Variant
Dim ShF1 As Worksheet
    Set ShF1 = Worksheets("BDD")
    Tb = ShF1.Range(ShF1.Cells(3, 1), ShF1.Cells(ShF1.Cells(65536, 5).End(xlUp).Row, 112))
Dim i, cptFr, cptAutr As Double
cptFr = 1: cptAutr = 1
' ***************************************************
Dim TabResFr() As Variant
ReDim TabResFr(1 To 8, 1 To 1)
Dim TabResAutr() As Variant
ReDim TabResAutr(1 To 8, 1 To 1)
' ***************************************************
Dim ShF2 As Worksheet
    Set ShF2 = Worksheets("TrieparIGC")
    ShF2.Range(ShF2.Cells(4, 1), ShF2.Cells(ShF2.Cells(65536, 3).End(xlUp).Row + 1, 15)).Interior.Pattern = xlNone
    ShF2.Range(ShF2.Cells(4, 1), ShF2.Cells(ShF2.Cells(65536, 3).End(xlUp).Row + 1, 15)).ClearContents
' ***************************************************
' Format
Dim RgnFormat(0 To 0, 0 To 1) As Range
    Set RgnFormat(0, 0) = ShF1.Range(ShF1.Cells(3, 95), ShF1.Cells(3, 95))
' ***************************************************
For i = LBound(Tb, 1) To UBound(Tb, 1)
        Clef = Tb(i, 12)
            If Clef = "France" Then
                TabResFr(1, cptFr) = Tb(i, 4)
                TabResFr(2, cptFr) = Tb(i, 5)
                TabResFr(3, cptFr) = Tb(i, 6)
                TabResFr(4, cptFr) = Tb(i, 18)
                TabResFr(5, cptFr) = CDbl(Tb(i, 19))
                TabResFr(6, cptFr) = Tb(i, 12)
                TabResFr(7, cptFr) = Tb(i, 112)
                TabResFr(8, cptFr) = Tb(i, 95)
                cptFr = cptFr + 1
                ReDim Preserve TabResFr(1 To 8, 1 To cptFr)
            Else
                TabResAutr(1, cptAutr) = Tb(i, 4)
                TabResAutr(2, cptAutr) = Tb(i, 5)
                TabResAutr(3, cptAutr) = Tb(i, 6)
                TabResAutr(4, cptAutr) = Tb(i, 18)
                TabResAutr(5, cptAutr) = CDbl(Tb(i, 19))
                TabResAutr(6, cptAutr) = Tb(i, 12)
                TabResAutr(7, cptAutr) = Tb(i, 112)
                TabResAutr(8, cptAutr) = Tb(i, 95)
                cptAutr = cptAutr + 1
                ReDim Preserve TabResAutr(1 To 8, 1 To cptAutr)
        End If
Next i
' Suppression d'une dimension
ReDim Preserve TabResFr(1 To 8, 1 To cptFr - 1)
ReDim Preserve TabResAutr(1 To 8, 1 To cptAutr - 1)
' Tri des tableaux
    TabResFr = Application.Transpose(TabResFr)
    TabResAutr = Application.Transpose(TabResAutr)
' Test dimension Variable tableau
    If NumberOfArrayDimensions(TabResFr) = 2 Then
        Tri TabResFr, 5, LBound(TabResFr, 1), UBound(TabResFr, 1)
        TabResFr = Application.Transpose(TabResFr)
    End If
    If NumberOfArrayDimensions(TabResAutr) = 2 Then
        Tri TabResAutr, 5, LBound(TabResAutr, 1), UBound(TabResAutr, 1)
        TabResAutr = Application.Transpose(TabResAutr)
    End If
' Transfert tableaux TabResFr
    Cpt = 4
    For i = 1 To 7
        ShF2.Cells(Cpt, i + 1).Resize(UBound(TabResFr, 2), 1) = Application.Index(Application.Transpose(TabResFr), , i)
    Next i
        ShF2.Cells(Cpt, 12).Resize(UBound(TabResFr, 2), 1) = Application.Index(Application.Transpose(TabResFr), , 8)
        Cpt = ShF2.Cells(65536, 2).End(xlUp).Row + 3
' Transfert tableaux TabResAutr
    For i = 1 To 7
        ShF2.Cells(Cpt, i + 1).Resize(UBound(TabResAutr, 2), 1) = Application.Index(Application.Transpose(TabResAutr), , i)
    Next i
        ShF2.Cells(Cpt, 12).Resize(UBound(TabResAutr, 2), 1) = Application.Index(Application.Transpose(TabResAutr), , 8)
        Cpt = ShF2.Cells(65536, 2).End(xlUp).Row + 1
' ***************************************************
' Format
    Set RgnFormat(0, 1) = ShF2.Range(ShF2.Cells(4, 12), ShF2.Cells(ShF2.Cells(65536, 2).End(xlUp).Row, 12))
                RgnFormat(0, 0).Copy
                RgnFormat(0, 1).PasteSpecial Paste:=xlPasteFormats
' ***************************************************
MsgBox Format(Timer - TI, "0.000\ sec.")
End Sub
Sub Tri(a(), ColTri, gauc, droi) ' Quick sort
    ref = a((gauc + droi) \ 2, ColTri)
    g = gauc: d = droi
    Do
      Do While a(g, ColTri) < ref: g = g + 1: Loop
      Do While ref < a(d, ColTri): d = d - 1: Loop
        If g <= d Then
           For k = LBound(a, 2) To UBound(a, 2)
             temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp
           Next k
           g = g + 1: d = d - 1
        End If
    Loop While g <= d
        If g < droi Then Call Tri(a, ColTri, g, droi)
        If gauc < d Then Call Tri(a, ColTri, gauc, d)
End Sub

Function NumberOfArrayDimensions(arr As Variant) As Integer
' https://stackoverflow.com/questions/24613101/vba-check-if-array-is-one-dimensional
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' NumberOfArrayDimensions
' This function returns the number of dimensions of an array. An unallocated dynamic array
' has 0 dimensions. This condition can also be tested with IsArrayEmpty.
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Dim Ndx As Integer
Dim Res As Integer
On Error Resume Next
' Loop, increasing the dimension index Ndx, until an error occurs.
' An error will occur when Ndx exceeds the number of dimension
' in the array. Return Ndx - 1.
    Do
        Ndx = Ndx + 1
        Res = UBound(arr, Ndx)
    Loop Until Err.Number <> 0
Err.Clear
NumberOfArrayDimensions = Ndx - 1
End Function

* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *

le code : Sans Scripting.Dictionary (Exemple 2 autres répartitions)

VB:
Option Explicit
Sub DicoTriTransfertLaurent950_ter()
' https://www.excel-downloads.com/threads/transfer-et-trie-dune-feuil-a-une-autre-feuil-meme-classeur.20049927/
Dim TI As Single
    TI = Timer
' ***************************************************
Dim Clef As String
' ***************************************************
Dim Tb() As Variant
Dim ShF1 As Worksheet
    Set ShF1 = Worksheets("BDD")
    Tb = ShF1.Range(ShF1.Cells(3, 1), ShF1.Cells(ShF1.Cells(65536, 5).End(xlUp).Row, 112))
Dim i, cptFr, cptAutr, Cpt, ResizCol As Double
    cptFr = 1: cptAutr = 1
' ***************************************************
Dim TabResFr() As Variant
    ReDim TabResFr(1 To 8, 1 To 1)
Dim TabResAutr() As Variant
    ReDim TabResAutr(1 To 8, 1 To 1)
' ***************************************************
Dim ShF2 As Worksheet
    Set ShF2 = Worksheets("TrieparIGC")
    ShF2.Range(ShF2.Cells(4, 1), ShF2.Cells(ShF2.Cells(65536, 3).End(xlUp).Row + 1, 15)).Interior.Pattern = xlNone
    ShF2.Range(ShF2.Cells(4, 1), ShF2.Cells(ShF2.Cells(65536, 3).End(xlUp).Row + 1, 15)).ClearContents
' ***************************************************
' Format
Dim RgnFormat(0 To 0, 0 To 1) As Range
    Set RgnFormat(0, 0) = ShF1.Range(ShF1.Cells(3, 95), ShF1.Cells(3, 95))
' ***************************************************
For i = LBound(Tb, 1) To UBound(Tb, 1)
        Clef = Tb(i, 12)
            If Clef = "France" Then
                TabResFr(1, cptFr) = Tb(i, 4)
                TabResFr(2, cptFr) = Tb(i, 5)
                TabResFr(3, cptFr) = Tb(i, 6)
                TabResFr(4, cptFr) = Tb(i, 18)
                TabResFr(5, cptFr) = CDbl(Tb(i, 19))
                TabResFr(6, cptFr) = Tb(i, 12)
                TabResFr(7, cptFr) = Tb(i, 112)
                TabResFr(8, cptFr) = Tb(i, 95)
                cptFr = cptFr + 1
                ReDim Preserve TabResFr(1 To 8, 1 To cptFr)
            Else
                TabResAutr(1, cptAutr) = Tb(i, 4)
                TabResAutr(2, cptAutr) = Tb(i, 5)
                TabResAutr(3, cptAutr) = Tb(i, 6)
                TabResAutr(4, cptAutr) = Tb(i, 18)
                TabResAutr(5, cptAutr) = CDbl(Tb(i, 19))
                TabResAutr(6, cptAutr) = Tb(i, 12)
                TabResAutr(7, cptAutr) = Tb(i, 112)
                TabResAutr(8, cptAutr) = Tb(i, 95)
                cptAutr = cptAutr + 1
                ReDim Preserve TabResAutr(1 To 8, 1 To cptAutr)
        End If
Next i
' Traitement des données
    Cpt = Transfert(TabResFr(), 4, UBound(TabResFr, 2) - 1, ShF2)
    Cpt = Transfert(TabResAutr, Cpt, UBound(TabResAutr, 2) - 1, ShF2)
' ***************************************************
' Format
    Set RgnFormat(0, 1) = ShF2.Range(ShF2.Cells(4, 12), ShF2.Cells(ShF2.Cells(65536, 2).End(xlUp).Row, 12))
                RgnFormat(0, 0).Copy
                RgnFormat(0, 1).PasteSpecial Paste:=xlPasteFormats
' ***************************************************
MsgBox Format(Timer - TI, "0.000\ sec.")
End Sub
Function Transfert(ByRef a() As Variant, ByVal Cpt As Double, ByRef ResizCol As Double, ByRef ShF2 As Worksheet) As Double
Dim i As Double
' Suppression d'une dimension
ReDim Preserve a(1 To 8, 1 To ResizCol - 1)
' Tri des tableaux
    a = Application.Transpose(a)
' Test dimension Variable tableau
    If NumberOfArrayDimensions(a) = 2 Then
        Tri a, 5, LBound(a, 1), UBound(a, 1)
        a = Application.Transpose(a)
    Else
        a = Application.Transpose(a)
    End If
' Transfert tableaux
    For i = 1 To 7
        ShF2.Cells(Cpt, i + 1).Resize(UBound(a, 2), 1) = Application.Index(Application.Transpose(a), , i)
    Next i
        ShF2.Cells(Cpt, 12).Resize(UBound(a, 2), 1) = Application.Index(Application.Transpose(a), , 8)
    If Cpt = 4 Then
        Transfert = ShF2.Cells(65536, 2).End(xlUp).Row + 3
    Else
        Transfert = ShF2.Cells(65536, 2).End(xlUp).Row + 1
    End If
End Function
Sub Tri(ByRef a() As Variant, ByRef ColTri As Double, ByVal gauc As Double, ByVal droi As Double) ' Quick sort
Dim ref, g, d, k As Double
Dim temp As Variant
    ref = a((gauc + droi) \ 2, ColTri)
    g = gauc: d = droi
    Do
      Do While a(g, ColTri) < ref: g = g + 1: Loop
      Do While ref < a(d, ColTri): d = d - 1: Loop
        If g <= d Then
           For k = LBound(a, 2) To UBound(a, 2)
             temp = a(g, k): a(g, k) = a(d, k): a(d, k) = temp
           Next k
           g = g + 1: d = d - 1
        End If
    Loop While g <= d
        If g < droi Then Call Tri(a, ColTri, g, droi)
        If gauc < d Then Call Tri(a, ColTri, gauc, d)
End Sub

Nota :
si les noms d'arguments ne sont pas précisés, c'est l'inverse. Le 1er argument de la méthode Add de l'objet Collection est l'item obligatoire. Le 2nd la clé facultative.
 

Pièces jointes

  • TrisQuickShortEtDictonaryTranfert.xlsm
    28.4 KB · Affichages: 3
Dernière édition:

Discussions similaires

Statistiques des forums

Discussions
311 725
Messages
2 081 947
Membres
101 849
dernier inscrit
florentMIG