Microsoft 365 Regroupement d'un tableau de 2 dimensions en vba

[Patrick46]

Bonjour à tous !!

J'ai regardé sur le forum mais je n'ai pas trouvé de solutions à mon problème.

Je suis assez novice en VBA l, bien que je l'étudié un peu en BTS. Je travaille depuis peu en tant que stagiaire dans une société et j'ai eu comme demande d'automatiser des tableaux en 2 dimensions sous forme de regroupements. J'arrive à faire un regroupement avec des IF mais je n'arrive pas à articuler les deux ensemble.

Je vous joins un fichier montrant le tableau d'origine et le regroupement que je souhaite obtenir.

Merci d'avance si vous avez une piste de départ ou un morceau de code qui pourrait me permettre de réaliser ce tableau.

Patrick

 

[job75]

Bonjour Patrick46, bienvenue sur XLD,

Voyez le fichier joint et cette formule en C26, à tirer à droite et vers le bas :

=SOMMEPROD((ARRONDI($A$2:$A$21;2)>=$A26)*(ARRONDI($A$2:$A$21;2)<=$B26)*($B$1:$V$1=C$25);$B$2:$V$21)

A+

 

[Patrick46]

Bonjour Patrick46, bienvenue sur XLD,

Voyez le fichier joint et cette formule en C26, à tirer à droite et vers le bas :

=SOMMEPROD((ARRONDI($A$2:$A$21;2)>=$A26)*(ARRONDI($A$2:$A$21;2)<=$B26)*($B$1:$V$1=C$25);$B$2:$V$21)

A+

Bonbjour Job 75

Merci pour ta réponse mais je me suis mal exprimé. Je veux que le regroupement se fasse aussi automatiquement sur les pourcentages dans la colonne A et sur les entêtes et non pas uniquement sur les données.

J'ai des milliers de tableau à traiter de cette façon, je ne pense pas qu'il soit possible de le faire uniquement en formules. Je pense qu'il est nécessaire de passer par le Vba pour automatiser le regroupement des entrées du tableau. Chaque tableau est différent donc chaque regroupement est différent.

 

[job75]

Alors il faudra être beaucoup plus clair...

 

[Patrick46]

Alors il faudra être beaucoup plus clair...

Désolé... je pensais que mon tableau d'exemple parlait de lui même...

 

[job75]

Oui il parle de lui-même et j'ai donné une solution qui parle aussi d'elle-même.

 

[Patrick46]

Merci de ton temps et de ton aide job75. Je vais essayer d'être plus précis :

je souhaite que le tableau de synthèse regroupe automatiquement :

1. les pourcentages selon les données qui se trouvent dans le tableau sous la forme 95% - 100% dans la même cellule
2. les colonnes sont aussi regroupés selon les données du tableau aux changements de valeurs ( de 0 à 500 on a 20 pour 95% à 100%, de 500 à 850 on a 21 pour 95% 100 % etc...) Ces colonnes doivent aussi être dynamique car chaque tableau sera différent.

J'espère que j'ai été plus clair. Désolé il est pas facile dès fois d'expliquer exactement ce qu'on souhaite faire.

Merci d'avance pour vos retours.

 

[Patrick46]

Est-ce que quelqu'un a une idée ou au moins un début de piste ?

 

[job75]

Bonjour Patrick46,

Je crois avoir enfin compris ce que vous voulez faire.

Il ne s'agit pas du tout de regroupement mais de déterminer les lignes et les colonnes où il y a variation des valeurs.

Voyez le fichier joint et cette macro :

Sub Variations()
Dim dest As Range, tablo, nlig&, ncol%, d1 As Object, d2 As Object, j%, i&, resu
Set dest = [A25] 'à adapter
tablo = [A1].CurrentRegion 'matrice, plus rapide
If Not IsArray(tablo) Then Exit Sub 'sécurité
nlig = UBound(tablo): ncol = UBound(tablo, 2)
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
'---détermination des variations par ligne---
d1("") = "" 'au moins 1 élément
For j = 2 To ncol
    For i = 2 To nlig
        If i = 2 Or tablo(i, j) <> tablo(i - 1, j) Then _
            If Not d1.exists(tablo(i, 1)) Then d1(tablo(i, 1)) = i 'mémorise la ligne
Next i, j
'---détermination des variations par colonne---
d2("") = "" 'au moins 1 élément
For i = 2 To nlig
    For j = 2 To ncol
        If j = 2 Or tablo(i, j) <> tablo(i, j - 1) Then _
            If Not d2.exists(tablo(1, j)) Then d2(tablo(1, j)) = j 'mémorise la colonne
Next j, i
Application.ScreenUpdating = False
'---en-têtes de lignes des résultats---
With dest.Resize(d1.Count)
    .Value = Application.Transpose(d1.keys) 'Transpose est limitée à 65536 lignes
    .Offset(d1.Count).Resize(Rows.Count - d1.Count - .Row + 1, Columns.Count - .Column + 1).Delete xlUp 'RAZ en dessous
    .Sort .Cells(1), xlDescending, Header:=xlYes, Orientation:=1 'tri vertical décroissant
End With
'---en-têtes de colonnes des résultats---
With dest.Resize(, d2.Count)
    .Value = d2.keys
    .Offset(, d2.Count).Resize(d1.Count, Columns.Count - d2.Count - .Column + 1).Delete xlToLeft 'RAZ à droite
    .Offset(, 1).Sort .Cells(1, 2), xlAscending, Orientation:=2 'tri horizontal croissant
End With
'---valeurs des résultats---
With dest.Resize(d1.Count, d2.Count)
    .Borders.Weight = xlThin 'bordures'
    resu = .Value 'matrice, plus rapide
    ncol = d2.Count
    For i = 2 To d1.Count
        For j = 2 To ncol
            resu(i, j) = tablo(d1(resu(i, 1)), d2(resu(1, j)))
    Next j, i
    .Value = resu
    With .Parent.UsedRange: End With 'actualise les barres de défilement
End With
End Sub

L'exécution est très rapide car on utilise des tableaux VBA et 2 Dictionary.

A+

 

[eriiic]

Bonjour,

ceci me semble bien plus rapide, 0.2s chez moi :

Sub compress()
    Dim datas, lig As Long, col As Long
    Dim t As Single
    t = Timer
    datas = [A1].CurrentRegion.Value
    Application.ScreenUpdating = False
    For lig = UBound(datas) To 2 Step -1
        For col = 2 To UBound(datas, 2)
            If datas(lig, col) <> datas(lig - 1, col) Then Exit For
        Next col
        If col = UBound(datas, 2) + 1 Then Rows(lig).Hidden = True
    Next lig
    For col = UBound(datas, 2) To 3 Step -1
        For lig = 2 To UBound(datas)
            If datas(lig, col) <> datas(lig, col - 1) Then Exit For
        Next lig
        If lig = UBound(datas) + 1 Then Columns(col).Hidden = True
    Next col
    [A1].CurrentRegion.SpecialCells(xlCellTypeVisible).Copy Cells(Rows.Count, 1).End(xlUp).Offset(3)
    [A1].CurrentRegion.EntireRow.Hidden = False
    [A1].CurrentRegion.EntireColumn.Hidden = False
    Debug.Print Timer - t
End Sub

on peut modifier un peu si tu désires vraiment garder la dernière colonne.

 

[job75]

Bonjour eriiic,

Ah oui bravo, avec le masquage c'est une solution bien plus simple et élégante que la mienne.

Chez moi, sur ta macro ou la mienne, la durée d'exécution est inférieure à 2 centièmes de secondes.

A+

 

[eriiic]

Merci
Ah oui, 10 fois plus rapide chez toi que chez moi, et la tienne met 3.6 s chez moi.
Je pense que 2020 sera l'année du changement de processeur pour moi. Après 10 ans de services il commence à être un peu dépassé.

 

[job75]

et la tienne met 3.6 s chez moi.

C'est sûrement sur le 1er fichier que j'avais posté à 12:16 mais à 13:53 j'ai modifié les RAZ et ce doit être plus rapide.

 

[eriiic]

Ah oui, c'est nettement mieux maintenant : 0.05 s
Je trouvais ce 3.6s étonnant aussi...

 

[job75]

Bonsoir Patrick46, eriiiic, le forum,

La solution d'eriiiic m'a permis de comprendre que les Dictionary ne sont pas du tout nécessaires.

Mais le masquage des lignes et colonnes ne me plaît pas : cela prendra trop de temps s'il y en a beaucoup.

Cette nouvelle solution me paraît optimale en repérant simplement les lignes et colonnes à ne pas conserver :

Sub Variations()
Dim dest As Range, tablo, nlig&, ncol%, i&, j%
Set dest = [A25] 'à adapter
tablo = [A1].CurrentRegion 'matrice, plus rapide
If Not IsArray(tablo) Then nlig = 1: ncol = 1: GoTo 3 'sécurité
nlig = UBound(tablo): ncol = UBound(tablo, 2)
'---repérage des lignes à ne pas conserver---
For i = 3 To nlig 'la 2ème ligne est conservée
    For j = 2 To ncol
        If tablo(i, j) <> tablo(i - 1, j) Then GoTo 1
    Next j
    tablo(i, 1) = "" 'repérage par effacement de l'en-tête
1 Next i
'---repérage des colonnes à ne pas conserver---
For j = 3 To ncol 'la 2ème colonne est conservée
    For i = 2 To nlig
        If tablo(i, j) <> tablo(i, j - 1) Then GoTo 2
    Next i
    tablo(1, j) = "" 'repérage par effacement de l'en-tête
2 Next j
'---création du tableau des résultats---
Application.ScreenUpdating = False
tablo(1, 1) = -"1E99" 'grand nombre négatif
3 With dest.Resize(nlig, ncol)
    .Value = tablo
    .Sort .Columns(1), xlDescending, Header:=xlYes, Orientation:=1 'tri vertical décroissant pour placer les en-têtes vides en bas
    nlig = Application.CountA(.Columns(1)) 'nouvelle valeur
    .Offset(nlig).Resize(Rows.Count - nlig - .Row + 1, Columns.Count - .Column + 1).Delete xlUp 'RAZ en dessous
    .Resize(nlig).Sort .Rows(1), xlAscending, Orientation:=2 'tri horizontal croissant pour placer les en-têtes vides à droite
    ncol = Application.CountA(.Rows(1)) 'nouvelle valeur
    .Offset(, ncol).Resize(nlig, Columns.Count - ncol - .Column + 1).Delete xlToLeft 'RAZ à droite
    .Resize(nlig, ncol).Borders.Weight = xlThin 'bordures
    .Cells(1) = ""
    With .Parent.UsedRange: End With 'actualise les barres de défilement
End With
End Sub

Fichier (2).

Bonne fin de soirée.