Somme selon critères BOUCLE VBA

Le 20/02/2017 à 16:06

Bonjour,

MERCI D'AVANCE A CELUI QUI AURA LE TEMPS DE M'AIDER, même si vous ne répondez pas à tout le sujet, une petite aide sur n'importe quel point me sera très utile !

J’aimerai que le tableau à bordures noires, s’ouvre dans une autre feuille avec le format du tableau à bordures rouges (pièce jointe)

Je m’explique, j’aimerai faire la somme de la colonne « nb of vehicle » selon plusieurs critères ..

J’aimerai faire une boucle dans VBA, avec « SOMME SI » :

SI A2 = A3 & B2 = B3 & C2=C3

& SI D2 commence par le même chiffre que D3 (il y à plusieurs type de transport dans une catégorie que j’ai appelé « 1 » dans mon exemple mais même si c’est pas exactement pareil je les additionne)

Alors SOMME, sinon passer au suivant

Il faut que ça s’additionne jusqu’à que 1 des critères ne correspond plus (voir canada dans tableau à bordures rouges)

Ce tableau n’est qu’une partie d’un tableau de 500 lignes

Si possible, j’aimerai qu’on ait juste à supprimer le tableau existant l’année prochaine, coller le nouveau tableau et lancer la macro qui me referait le même exercice … De plus, les valeurs trouvées sont affichées dans une carte (toujours sous excel dans une autre feuille du classeur) j’aimerai que du coup si en Algérie on fait 30 véhicule l’année d’après au lieu de 11, que ce résultat se change tout seul sur ma carte …

test
Le 20/02/2017 à 19:01

Salut Vinz,

une procédure à l'aveugle, à coller dans le module de ta feuille (pas un module général), sans fichier, à tester sur un fichier-test renommé, histoire d'éviter les catastrophes.

Cliquer sur [A1] pour démarrer la macro!

Si ça foire, prière de...

Private Sub Worksheet_SelectionChange(ByVal Target As Range)
'
Dim tTab, tTabF()
'
If Target.Address = [A1].Address Then
    iRow = Range("A" & Rows.Count).End(xlUp).Row
    Range("A2:E" & iRow).Sort key1:=Range("A2"), order1:=xlAscending, key2:=Range("B2"), order2:=xlAscending, key3:=Range("D2"), order3:=xlAscending
    tTab = Range("A1:E" & iRow)
    For x = 2 To UBound(tTab, 1)
        If tTab(x, 1) <> tTab(x - 1, 1) And tTab(x, 2) <> tTab(x - 1, 2) And tTab(x, 4) <> tTab(x - 1, 4) Then
            iIdx = iIdx + 1
            ReDim Preserve tTabF(5, iIdx)
        End If
        For y = 1 To 5
            tTabF(y - 1, iIdx - 1) = IIf(y < 5, tTab(x, y), tTabF(y - 1, iIdx - 1) + tTab(x, y))
        Next
    Next
    Range("A2").Resize(UsedRange.Rows.Count, UsedRange.Columns.Count).Delete
    Range("A2").Resize(iIdx, 5) = WorksheetFunction.Transpose(tTabF)
    Range("A2").Resize(iIdx, 5).Borders.LineStyle = 1
End If
'
End Sub

A+

Le 20/02/2017 à 19:23

Bonsoir vinz56, salut curulis57,

C'est vrai que les données, plutôt qu'en image, auraient pu être fournies dans un bon vieux classeur!

Sans garantie non plus (on ne sait même pas les noms des feuilles!?) ... une autre approche ... à coller dans un module standard, dans le cas présent:

Sub Conso()
Set liste = CreateObject("scripting.dictionary")
With Feuil1
    tablo = .Range("a2:E" & .Cells(Rows.Count, 1).End(xlUp).Row)
    For i = 1 To UBound(tablo)
        liste(tablo(i, 1) & "#" & tablo(i, 2) & "#" & tablo(i, 3) & "#" & Left(tablo(i, 4), 1)) = _
            liste(tablo(i, 1) & "#" & tablo(i, 2) & "#" & tablo(i, 3) & "#" & Left(tablo(i, 4), 1)) + tablo(i, 5)
    Next i
End With
lig = 2
With Feuil2
    For Each k In liste.keys
        .Cells(lig, 1).Resize(1, 4) = Split(k, "#")
        lig = lig + 1
    Next k
    .[E2].Resize(liste.Count, 1) = Application.Transpose(liste.items)
End With
End Sub
Le 21/02/2017 à 08:51

Merci pour vos réponses très rapides !

J'ai testé celui de U.milité et il fonctionne sur mon fichier test, pourrais tu mettre des commentaires afin que je puisse le modifier pour mon fichier pro ? je ne suis pas super bon en macro ...

Le 21/02/2017 à 18:46

Bonjour,

Pour l'utilisation d'un objet "Dictionary", je te conseille de chercher des infos complémentaires: je ne saurais tout expliquer ici. Retiens déjà que qu'il permet de gérer très facilement les doublons et qu'il est d'une grande rapidité. Chez Jacques Boisgontier, il y a de quoi t'occuper quelques heures

Ci-dessous, quelques commentaires dans le code:

Sub Conso()
Set liste = CreateObject("scripting.dictionary") 'déclaration de l'objet 'Dictionary'
With Feuil1 'on fera référence, à la ligne suivante, à la Feuil1
    tablo = .Range("a2:E" & .Cells(Rows.Count, 1).End(xlUp).Row) 'pour la rapidité, on "charge" toutes les données dans un tableau en mémoire
    For i = 1 To UBound(tablo) 'on parcourt toutes les lignes de ce tableau
        'les clés du Dictionary sont constituées des valeurs concaténées des 3 premières colonnes + la première lettre de la 4e colonne
        'pour chaque clé (--> Key), les valeurs correspondantes en colonne 5 sont additionnées (--> Item)
        liste(tablo(i, 1) & "#" & tablo(i, 2) & "#" & tablo(i, 3) & "#" & Left(tablo(i, 4), 1)) = _
            liste(tablo(i, 1) & "#" & tablo(i, 2) & "#" & tablo(i, 3) & "#" & Left(tablo(i, 4), 1)) + tablo(i, 5)
    Next i
End With
lig = 2
With Feuil2
    For Each k In liste.keys 'pour chaque clé du Dictionary, on "splitte" la clé en 4 éléments ('#' est le séparateur utilisé)
        .Cells(lig, 1).Resize(1, 4) = Split(k, "#") 'dans chaque ligne de Feuil2, les 4 premières colonnes sont garnies
        lig = lig + 1
    Next k
    .[E2].Resize(liste.Count, 1) = Application.Transpose(liste.items) 'ne reste plus qu'à inscrire en 5e colonne, les chiffres cumulés
End With
End Sub
Le 22/02/2017 à 10:05

Merci beaucoup de ton aide !

Bonne continuation et à bientôt surement !

Rechercher des sujets similaires à "somme criteres boucle vba"