[XL-2003] Sous-totaux (ou équivalent)) en vba pour affichage hiérarchique [Résolu]

[Jaymerry]

Bonjour à tous,

Je souhaiterais reproduire avec VBA les sous-totaux présents dans ce fichier que l'on m'a transmis comme modèle.
Jusqu'à présent, impossible d'obtenir le même résultat même en ajoutant manuellement les sous-totaux (l'ordre de ces derniers n'est correct pas, quelque soit la manière dont je les ajoute..).

Idem en utilisant VBA :

Code :

1
2
Range("A3").CurrentRegion.Subtotal GroupBy:=1, Function:=xlSum, TotalList:=Array(1, 1), _
  Replace:=False, PageBreaks:=False, SummaryBelowData:=False

Impossible d'obtenir le même ordre (d'abord TEST, puis FICHE1, puis FICHE1A)

Je suis parti sur les sous-totaux pour obtenir ce résultat (+ et - sur la gauche pour masquer / afficher un groupe de ligne), mais je fais peut être fausse route ; voyez-vous comment obtenir un tel affichage ?

Merci à tous pour votre aide,

Jaymerry

[ZebreLoup]

Pour mieux comprendre :
Tu veux faire des sous-totaux de quoi ? Il n'y a pas de nombres dans ton fichier.
Ton but est de transformer les lignes 4,6,8,9,10 en ce qu'il y a actuellement ?
On est bien d'accord qu'il n'y a que des FICHE1 dans la colonne B et que c'est FICHIE1B qu'il doit y avoir en C6 ?

Pour faire une macro, je te conseillerais de boucler de la colonne C à la colonne A l'algorithme suivant :
Dès que nouvelle valeur dans la cellule, on ajoute une ligne au dessus en recopiant toutes les données jusqu'à la colonne en question.
Passage à la ligne suivante.

Et si on a garder le numéro de ligne du dernier changement on peut faire un

Code :

Rows(iOld+1 & ":" & iNew).Group

Voici un exemple de code à adapter. Il part des données brutes qui commencent en A1 (cf Image en PJ) :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
Option Explicit
 
Public Sub groupeToutesColonnes()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    ws.Outline.SummaryRow = xlSummaryAbove
 
    Dim i As Integer
 
    For i = 3 To 1 Step -1
        grouperColonne i
    Next i
 
End Sub
 
Private Sub grouperColonne(ByVal colNum As Integer)
    Dim lastValue As String
    Dim actualValue As String
    Dim currentRow As Integer
    Dim lastRowChange As Integer
    Dim j As Integer
 
    lastValue = "TrucQuonNeRisquePasDavoirDansLaColonne"
    currentRow = 1
    lastRowChange = -1
 
    Do
        actualValue = Cells(currentRow, colNum).Value
 
        If actualValue <> lastValue Then
            'On ajoute la ligne de sous-total
            Rows(currentRow & ":" & currentRow).Insert shift:=xlDown
            currentRow = currentRow + 1
            For j = 1 To colNum
                Cells(currentRow - 1, j).Value = Cells(currentRow, j).Value
                Cells(currentRow - 1, j).Interior.ColorIndex = colNum + 7
            Next j
 
            'On groupe les données
            If lastRowChange <> -1 Then
                Rows(lastRowChange & ":" & currentRow - 2).Group
            End If
 
            lastRowChange = currentRow
            lastValue = actualValue
        End If
 
        currentRow = currentRow + 1
    Loop While Cells(currentRow, colNum).Value <> ""
 
    'On groupe les données
    If lastRowChange <> -1 Then
        Rows(lastRowChange & ":" & currentRow - 1).Group
    End If
 
End Sub

[Jaymerry]

Bonjour,

Effectivement tu as bien compris mon problème.
Il n'est pas question à proprement parler de "sous-totaux" (puisqu'il n'y a pas de chiffres) mais plutôt de regroupements hiérarchisés de valeurs.

Ton algo m'a beaucoup aidé ; sauf que dans certains cas, les valeurs de la colonne A peuvent être différentes. Comme dans ton exemple, les valeurs de la colonne sont toujours les valeurs "parentes" des colonnes B et C ; B étant uniquement parente de C.
Actuellement, la fonction groupeToutesColonnes() affecte une nouvelle valeur de la colonne A en même position qu'une valeur de la colonne C.

Du coup j'essaie de "séquencer" ta fonction ; de la stopper si la valeur suivante de la colonne A est différente de la valeur courante pour relancer tout le traitement (en le redémarrant depuis la ligne avec la nouvelle valeur de la colonne A), mais je m'arrache un peu les cheveux...

Si tu as une idée sur ce sujet, n'hésite pas..

Dans tous les cas, merci pour ton aide déjà apportée

Jaymerry

[ZebreLoup]

Je n'ai pas bien compris le problème, normalement ça marche même s'il y a des choses différentes en A.
Au pire, si tes données ne sont pas triées, il faut commencer par trier selon la colonne C, puis B, puis A.

[Jaymerry]

Le souci ne vient pas du tri , mes données sont déjà triées en fonction des valeurs de la colonne A dans la feuille source.

Avec la fonction groupeToutesColonnes, une nouvelle valeur dans la colonne A n'entraine pas un regroupement au niveau de la colonne A.
Pour résumer, cette fonction est niquel avec un seul noeud pour le 1er niveau de la hiérarchie.

Dans le fichier joint à ce post se trouve un exemple (probablement plus clair) avec plusieurs nœuds pour le 1er niveau de la hiérarchie et le résultat de groupeToutesColonnes avec des valeurs différentes.

Merci pour ton aide,

Jaymerry

[ZebreLoup]

Oui, désolé, je n'avais pas compris le problème.
Je n'avais pas pris en compte le cas où ça change en A sans changer en B.
Il faut donc revoir le principe. Je dirais soit :
- Boucler de A vers C plutôt que de C vers A, en adaptant l'algo pour gérer les cellules vides.
- Garder l'algo actuel mais sans le regroupement et faire une deuxième passe pour le regroupement ensuite.

Je vais regarder ça.

[ZebreLoup]

La deuxième passe est sans doute le mieux car l'insertion des nouvelles lignes n'est pas évidente à gérer quand un regroupement existe déjà.

Voici un code qui cette fois devrait fonctionner :

Code :

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
Option Explicit
 
Public Sub groupeToutesColonnes()
    Dim ws As Worksheet
    Set ws = ActiveSheet
    ws.Outline.SummaryRow = xlSummaryAbove
 
    Dim i As Integer
    Dim nbRow As Integer
 
    For i = 3 To 1 Step -1
        creerHierarchie i, nbRow
    Next i
 
    For i = 3 To 1 Step -1
        grouperColonnes i, nbRow
    Next i
End Sub
 
Private Sub grouperColonnes(ByVal colNum As Integer, ByVal nbRow As Integer)
    Dim inGroup As Boolean
    Dim lastValue As String
    Dim actualValue As String
    Dim currentRow As Integer
    Dim lastRowChange As Integer
    Dim j As Integer
 
    inGroup = False
    currentRow = 1
    lastValue = ""
 
    Do
        actualValue = Cells(currentRow, colNum).Value
 
        If lastValue <> actualValue Then
            lastValue = actualValue
 
            'Si on est dans un groupe on en sort et on le regroupe
            If inGroup Then
                inGroup = False
                Rows(lastRowChange & ":" & currentRow - 1).Group
            End If
 
            'Si la nouvelle valeur est non vide, on entre dans un nouveau groupe
            If actualValue <> "" Then
                inGroup = True
                currentRow = currentRow + 1
                lastRowChange = currentRow
            End If
        End If
 
        currentRow = currentRow + 1
    Loop While currentRow <= nbRow + 1
End Sub
 
Private Sub creerHierarchie(ByVal colNum As Integer, ByRef nbRow As Integer)
    Dim lastValue() As String
    Dim actualValue() As String
    Dim currentRow As Integer
    Dim j As Integer
 
    ReDim lastValue(colNum - 1)
    ReDim actualValue(colNum - 1)
 
    For j = 1 To colNum
        lastValue(j - 1) = "TrucQuonNeRisquePasDavoirDansLaColonne"
    Next j
 
    currentRow = 1
 
    Do
        For j = 1 To colNum
            actualValue(j - 1) = Cells(currentRow, j).Value
        Next j
 
        If Not compareTableau(actualValue, lastValue) Then
            'On ajoute la ligne de sous-total
            Rows(currentRow & ":" & currentRow).Insert shift:=xlDown
            currentRow = currentRow + 1
            For j = 1 To colNum
                Cells(currentRow - 1, j).Value = actualValue(j - 1)
                Cells(currentRow - 1, j).Interior.ColorIndex = colNum + 7
            Next j
 
            lastValue = actualValue
        End If
 
        currentRow = currentRow + 1
    Loop While Cells(currentRow, colNum).Value <> ""
 
    nbRow = currentRow - 1
End Sub
 
Private Function compareTableau(ByRef val1() As String, ByRef val2() As String) As Boolean
    Dim j As Integer
    Dim ok As Boolean
    ok = True
 
    For j = 0 To UBound(val1)
        If val1(j) <> val2(j) Then ok = False
    Next j
 
    compareTableau = ok
End Function

[Jaymerry]

C'est exactement ça

Merci milles fois pour ta précieuse aide !