[VBA] "Boucler" sur un dictionnaire pour additionner

Bonsoir,

Dans mon projet, je génère un tableau dont la clé correspond à une valeur de surface et les items à une concaténation de deux colonnes.

Si, dans mon tableau, la valeur recherchée correspond à ce qui se trouve dans le dictionnaire, alors je demande à additionner (dans une variable tableau) la clé avec la valeur précédente (lorsque la recherche est identique, mais la clé différente).

Sauf que je ne peux pas boucler dans mon dictionnaire... Je sais que c'est faisable, j'ai vu des fonctions qui avaient l'air de faire exactement cela, mais je ne vois pas comment les faire fonctionner...

Ci-après mon code, ainsi qu'un fichier exemple si vous souhaitez y jeter un œil.

Merci de votre attention !

Bonne soirée :)

Sub RechSum()
Dim a%, i%, lrjo&, lcjo&, cle As Byte, tablo1, tablo2, tablo3, tablo4, dict1 As Object, tab1()

Set dict1 = CreateObject("scripting.dictionary")
With jo
    lrjo = .UsedRange.SpecialCells(xlCellTypeLastCell).Row: lcjo = .UsedRange.Columns.Count
    tablo1 = .Range(.Cells(2, cell1), .Cells(lrjo, cell1)): tablo2 = .Range(.Cells(2, cell2), .Cells(lrjo, cell2))
    tablo3 = .Range(.Cells(2, cell3), .Cells(lrjo, cell3))
        For a = LBound(tablo1) To UBound(tablo1)
            dict1(tablo1(a, 1) & tablo3(a, 1)) = tablo2(a, 1)
        Next a
End With

With ActiveSheet
    lras = .UsedRange.SpecialCells(xlCellTypeLastCell).Row: lcas = .UsedRange.Columns.Count
    cle = .Range("1:1").Find("CONCAT_TEMP", LookIn:=xlValues, Lookat:=xlWhole).Column
    tablo4 = .Range(.Cells(2, cle), .Cells(lras, cle)): ReDim tab1(1 To lras - 1, 1 To 1)
        With jo
            For a = 2 To UBound(tablo4)
                For i = 1 To dict1.Count
                    If dict1.exists(tablo4(a, 1) & "1") Then tab1(a - 1, 1) = tab1(a - 1, 1) + dict1(tablo4(a, 1) & "1")
                Next i
            Next a
        End With
    .Cells(2, cle + 1).Resize(lras - 1, 1) = tab1:.Cells(1, cle + 1) = "SUM_SURF"   
End With
End Sub

Bonsoir,

avec votre fichier je n'avais aucun résultat affiché, et en modifiant cette ligne je me retrouve avec une liste de 21 résultat identiques :
.Cells(2, cle + 1).Resize(lras - 1, 1) = Application.Transpose(tab1)
Je présume que ce n'est pas le résultat attendu !

@ bientôt

LouReeD

Bonsoir,

Je reupload le document, peut-être que je n'avais pas enregistré la dernière version.

Quoi qu'il en soit, je ne pense pas que ce soit le résultat attendu

Les résultats ne sont pas supposés être identiques puisque ce sont des additions réalisées à partir des clés du dictionnaire, en fonction de ce qui est recherché.

Merci d'avoir regardé ! :)

Bonjour,

J'ai essayé de passer par des variables tableau, mais j'ai une erreur "L'indice n'appartient pas à la sélection" alors que le tableau est bien redimensionné.

L'erreur apparaît sur cette ligne : bb(y, 1) = tablo2(a, 1): bb(y, 2) = tablo1(a, 1): y = y + 1

Le code c'est celui-ci :

Private Sub CommandButton1_Click()
Dim lras%, lcas%, lrjo&, lcjo&, a%, i%, y%, cle As Byte, tablo1, tablo2, tablo3, tablo4, dict1 As Object, bb, tab1, tab2

Call Set_Feuilles
Call decl_var

With jo
    On Error Resume Next 'temp
    cell1 = .Range("1:1").Find("Concat : N° impct - hab", LookIn:=xlValues, Lookat:=xlWhole).Column 'temp
    '    If cell1 > 0 Then .Cells(1, cell1).EntireColumn.Delete 'temp
    On Error Resume Next 'temp
    cell2 = .Range("1:1").Find("SURF_TEMP", LookIn:=xlValues, Lookat:=xlWhole).Column 'temp
    '    If cell2 > 0 Then .Cells(1, cell2).EntireColumn.Delete 'temp
    On Error Resume Next 'temp
    cell3 = .Range("1:1").Find("verif", LookIn:=xlValues, Lookat:=xlWhole).Column 'temp
    '    If cell3 > 0 Then .Cells(1, cell3).EntireColumn.Delete 'temp

'###########################ERREUR#################################################################
    y = 1: lrjo = .UsedRange.SpecialCells(xlCellTypeLastCell).Row: lcjo = .UsedRange.Columns.Count
    tablo1 = .Range(.Cells(2, cell1), .Cells(lrjo, cell1)): tablo2 = .Range(.Cells(2, cell2), .Cells(lrjo, cell2))
    tablo3 = .Range(.Cells(2, cell3), .Cells(lrjo, cell3))
    ReDim bb(1 To y, 1 To 2)
        For a = LBound(tablo1) To UBound(tablo1)
            If Not tablo3(a, 1) = 0 Then
                ReDim Preserve bb(1 To y, 1 To 2)
                bb(y, 1) = tablo2(a, 1): bb(y, 2) = tablo1(a, 1): y = y + 1 '                < ICI (bb(y,1) et bb(y,2))
            End If
        Next a
End With
'##################################################################################################

With ActiveSheet
    lras = .UsedRange.SpecialCells(xlCellTypeLastCell).Row: lcas = .UsedRange.Columns.Count
    cle = .Range("1:1").Find("CONCAT_TEMP", LookIn:=xlValues, Lookat:=xlWhole).Column
    tablo4 = .Range(.Cells(1, cle), .Cells(lras, cle)): ReDim tab2(1 To lras - 1, 1 To 1)
        With jo
            For a = 2 To UBound(tablo4)
                For i = 1 To UBound(bb)
                    If dict1(tablo4(a, 1) & "1") Then
                        tab2(a - 1, 1) = tab2(a - 1, 1) + bb(i, 1)
                    Else:
                        tab2(a - 1, 1) = tab2(a - 1, 1) + 0
                    End If
                Next i
            Next a
        End With
    .Cells(2, cle + 1).Resize(lras - 1, 1) = tab1: .Cells(1, cle + 1) = "SUM_SURF"
End With
'jo.Columns(cell3).EntireColumn.Delete: jo.Columns(cell2).EntireColumn.Delete: jo.Columns(cell1).EntireColumn.Delete
'Set rng1 = Nothing
End Sub

Bonne journée !

Finalement pour le moment je vais m'y prendre comme ça (voir code ci-après).

En utilisant Ubound(bb) je me retrouve à boucler sur 8 000 lignes (dont 7980 vides), pour 23 lignes remplies dans bb... Tout ça parce que j'ai une erreur quand je souhaite redimensionner bb avec la variable y. Je n'ai pas cette erreur généralement, mais là oui, alors il y a peut-être encore un petit élément que je n'ai pas repéré, mais même en refaisant la macro j'ai la même chose (macro que je tire d'une autre macro qui fonctionne !).

Le temps d'exécution est plutôt rapide : Moins d'une seconde pour 16 000 lignes testées.

Bonne soirée !

    y = 1: lrjo = .UsedRange.SpecialCells(xlCellTypeLastCell).Row: lcjo = .UsedRange.Columns.Count
    tablo1 = .Range(.Cells(2, cell1), .Cells(lrjo, cell1)): tablo2 = .Range(.Cells(2, cell2), .Cells(lrjo, cell2))
    tablo3 = .Range(.Cells(2, cell3), .Cells(lrjo, cell3))

    ReDim bb(1 To lrjo, 1 To 2)
        For a = LBound(tablo1) To UBound(tablo1)
            If Not tablo3(a, 1) = 0 Then
                ReDim Preserve bb(1 To y, 1 To 2): bb(y, 1) = tablo2(a, 1)
                ReDim Preserve bb(1 To y, 1 To 2): bb(y, 2) = tablo1(a, 1): y = y + 1
            End If
        Next a
End With
'
With ActiveSheet
    lras = .UsedRange.SpecialCells(xlCellTypeLastCell).Row: lcas = .UsedRange.Columns.Count
    cle = .Range("1:1").Find("CONCAT_TEMP", LookIn:=xlValues, Lookat:=xlWhole).Column
    tablo4 = .Range(.Cells(1, cle), .Cells(lras, cle)): ReDim tab1(1 To lras - 1, 1 To 1)
        With jo
            For a = 2 To UBound(tablo4)
                For i = 1 To UBound(bb)
                    If tablo4(a, 1) = bb(i, 2) Then
                        tab1(a - 1, 1) = tab1(a - 1, 1) + bb(i, 1)
                    Else
                        tab1(a - 1, 1) = tab1(a - 1, 1) + 0
                    End If
                Next i
            Next a
        End With
    .Cells(2, cle + 1).Resize(lras - 1, 1) = tab1: .Cells(1, cle + 1) = "SUM_SURF"
End With