XL pour MAC Créer un sous groupe à partir d'un groupe

[rtlv17]

Bonjour, je souhaite créer une liste de sous groupe à partir d'un groupe d'éléments.

Je m'explique :

A partir d'une liste que j'appelle compte et qui contient des éléments tels que : Alimentation ; Cadeaux ; Voitures ; Loisirs ...

Je souhaite, au regard de chaque compte lister des noms tels que : Intermarché,Leclerc,Boulangerie... ; Pierre,Paul,Jacques... ; Porsche,Ferrari,Renault... ; SNCF,Parc,Livres...

Les informations viennent d'un onglet "journal" dans lequel je saisi au quotidien mes dépenses.

De préférence une formule car je ne suis pas expert en VBA

Merci beaucoup.

A bientôt

Un exemple :

 

[job75]

Dans le fichier du post #14 :

- le tableau de la feuille "Journal" ne contient plus rien

- dans la feuille "Matrice" le tableau des comptes en BX3 a disparu !

Aucune cohérence dans tout cela.

 

[rtlv17]

J'ai transmis un nouveau fichier dans la post #15 avec des données dans "Journal" et le tableau en CC dans "Matrice".

 

[job75]

J'ai l'impression que vous n'avez même pas pris la peine de simplement regarder ma macro.

En effet pour votre fichier du post #15 il suffisait de remplacer [BX3] par [CC3] au niveau de la feuille "Matrice" !

Ma macro est dans Module2, elle se lance comme je l'ai dit par le raccourci clavier Ctrl+F.

 

[rtlv17]

J'ai l'impression que vous n'avez même pas pris la peine de simplement regarder ma macro.

En effet pour votre fichier du post #15 il suffisait de remplacer [BX3] par [CC3] au niveau de la feuille "Matrice" !

Ma macro est dans Module2, elle se lance comme je l'ai dit par le raccourci clavier Ctrl+F.

Merci pour vos efforts job75 cependant je vous trouve bien condescendant.

J'ai ausculté votre macro, j'avais modifié BX3 en CC3 qui correspond à la position du tableau, cependant au lancement de la macro j'obtiens la réaction en fichier transmis.

Et là, je suis bien incapable de résoudre cette erreur car, je vous le disais dans un post précédent, mais j'ai l'impression que vous ne lisez pas tout, je ne suis pas un expert de vba.

Je porte toutefois un intérêt certain à vos réponses.

Merci encore

 

[job75]

Pour peaufiner j'ai créé un tableau structuré (Tableau1) dans la feuille "Matrice".

Et j'ai remplacé la macro précédente par celle-ci dans le code de cette feuille :

Private Sub Worksheet_Activate()
Dim tablo, d As Object, col%, c As Range, x$, n&, resu(), i&, y$, nn&, v, hauteur&
With Sheets("Journal")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    tablo = .Range("B7:I" & .Cells(Rows.Count, 2).End(xlUp).Row) 'matrice, plus rapide
End With
Set d = CreateObject("Scripting.Dictionary")
d.CompareMode = vbTextCompare 'la casse est ignorée
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'évite le recalcul des formules volatiles
With [Tableau1] 'tableau structuré
    .ListObject.ShowTotals = False 'masque la ligne Total
    For col = 1 To .Columns.Count Step 2
        Set c = .Cells(0, col) 'ligne des en-têtes
        x = LCase(Trim(c))
        n = 0
        ReDim resu(1 To UBound(tablo), 1 To 2) 'réinitialise le tableau des résultats
        For i = 1 To UBound(tablo)
            If LCase(Trim(tablo(i, 2))) = x Then
                y = Trim(tablo(i, 3))
                If Not d.exists(y) Then
                    n = n + 1
                    d(y) = n 'mémorise la ligne
                    resu(n, 1) = y
                End If
                nn = d(y)
                v = tablo(i, 8)
                If IsNumeric(v) Then resu(nn, 2) = resu(nn, 2) + CDbl(v)
            End If
        Next i
        If n Then c(2).Resize(n, 2) = resu 'restitution
        If n > hauteur Then hauteur = n
    Next col
    If .Rows.Count > hauteur Then .Rows(hauteur + 1).Resize(.Rows.Count - hauteur).Delete xlUp 'RAZ en dessous
    .ListObject.ShowTotals = True 'affiche la ligne Total
    .EntireColumn.AutoFit 'ajustement largeurs
End With
Application.Calculation = xlCalculationAutomatic
End Sub

Elle se déclenche automatiquement quand on active la feuille "Matrice".

 

[job75]

Ah pardon, je n'avais pas vu que vous êtes su MAC.

En effet le Dictionary n'est pas accepté sur MAC, je vais donc le remplacer par une Collection.

 

[job75]

Donc voici la macro avec une Collection qui fonctionne sur MAC comme sur Windows :

Option Compare Text 'la casse est ignorée

Private Sub Worksheet_Activate()
Dim tablo, col%, c As Range, x$, n&, resu(), i&, y$, coll As New Collection, v, hauteur&
With Sheets("Journal")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    tablo = .Range("B7:I" & .Cells(Rows.Count, 2).End(xlUp).Row) 'matrice, plus rapide
End With
Application.ScreenUpdating = False
Application.Calculation = xlCalculationManual 'évite le recalcul des formules volatiles
With [Tableau1] 'tableau structuré
    .ListObject.ShowTotals = False 'masque la ligne Total
    For col = 1 To .Columns.Count Step 2
        Set c = .Cells(0, col) 'ligne des en-têtes
        x = LCase(Trim(c))
        n = 0
        ReDim resu(1 To UBound(tablo), 1 To 2) 'réinitialise le tableau des résultats
        For i = 1 To UBound(tablo)
            If LCase(Trim(tablo(i, 2))) = x Then
                y = Trim(tablo(i, 3))
                n = n + 1
                On Error Resume Next
                coll.Add n, y
                If Err Then n = n - 1 Else resu(n, 1) = y
                v = tablo(i, 8)
                If IsNumeric(v) Then resu(coll(y), 2) = resu(coll(y), 2) + CDbl(v)
            End If
        Next i
        If n Then c(2).Resize(n, 2) = resu 'restitution
        If n > hauteur Then hauteur = n
    Next col
    If .Rows.Count > hauteur Then .Rows(hauteur + 1).Resize(.Rows.Count - hauteur).Delete xlUp 'RAZ en dessous
    .ListObject.ShowTotals = True 'affiche la ligne Total
    .EntireColumn.AutoFit 'ajustement largeurs
End With
Application.Calculation = xlCalculationAutomatic
End Sub

 

[rtlv17]

Donc voici la macro avec une Collection qui fonctionne sur MAC comme sur Windows :

Option Compare Text 'la casse est ignorée

Private Sub Worksheet_Activate()
Dim tablo, col%, c As Range, x$, n&, resu(), i&, y$, coll As New Collection, v
With Sheets("Journal")
    If .FilterMode Then .ShowAllData 'si la feuille est filtrée
    tablo = .Range("B7:I" & .Cells(Rows.Count, 2).End(xlUp).Row) 'matrice, plus rapide
End With
Application.ScreenUpdating = False
With [Tableau1] 'tableau structuré
    If Not .ListObject.DataBodyRange Is Nothing Then .Delete 'RAZ
    For col = 1 To .Columns.Count Step 2
        Set c = .Cells(0, col) 'ligne des en-têtes
        x = LCase(Trim(c))
        n = 0
        ReDim resu(1 To UBound(tablo), 1 To 2) 'réinitialise le tableau des résultats
        For i = 1 To UBound(tablo)
            If LCase(Trim(tablo(i, 2))) = x Then
                y = Trim(tablo(i, 3))
                n = n + 1
                On Error Resume Next
                coll.Add n, y
                If Err Then n = n - 1 Else resu(n, 1) = y
                v = tablo(i, 8)
                If IsNumeric(v) Then resu(coll(y), 2) = resu(coll(y), 2) + CDbl(v)
            End If
        Next i
        If n Then c(2).Resize(n, 2) = resu 'restitution
    Next col
    .EntireColumn.AutoFit 'ajustement largeurs
End With
End Sub

Voila deux copies d'écran :
la première au lancement de la macro ---> je ne fais peut être pas la copie correctement
la deuxième lorsque j'ouvre le fichier que vous m'avez transmis.

Vous avez écrit dans le post #20 "Pour peaufiner j'ai créé un tableau structuré (Tableau1) dans la feuille "Matrice"."
Je ne trouve pas ce tableau.

 

[job75]

Le fichier du post #20 utilise le Dictionary qui ne fonctionne pas sur MAC, donc travaillez avec le fichier du post #22.

Vous nous parlez de 2 copies d'écran mais vous ne les avez pas jointes.

 

[job75]

Bonjour le forum,

Dans les macros des posts #20 et #22 j'ai ajouté les Application.Calculation = xlCalculationManua/xlCalculationAutomatic.

Cela évite le recalcul des formules volatiles et fait gagner un peu de temps.

Par ailleurs j'ai ajouté la ligne Total dans le tableau structuré de la feuille "Matrice".

 

[rtlv17]

Bonjour le forum,

Dans les macros des posts #20 et #22 j'ai ajouté les Application.Calculation = xlCalculationManua/xlCalculationAutomatic.

Cela évite le recalcul des formules volatiles et fait gagner un peu de temps.

A+

Bonjour,

Voilà

 

[job75]

Pour le 2ème message Option Compare Text doit être en haut de la feuille, pas dans une macro.

Et pourquoi n'utilisez-vous pas la macro Worksheet_Activate que j'ai donnée ???

 

[rtlv17]

Pour le 2ème message Option Compare Text doit être en haut de la feuille, pas dans une macro.

Et pourquoi n'utilisez-vous pas la macro Worksheet_Activate que j'ai donnée ???

Je vous disais que je ne suis pas très à l'aise avec vba !!

J'essaie de nouveau...

 

[rtlv17]

Je vous disais que je ne suis pas très à l'aise avec vba !!

J'essaie de nouveau...

Désolé, je n'arrive pas à appliquer votre solution à mon application.
Je ne comprends pas ce que vous me demandez de faire, en conséquence je dois mal faire.

Voilà une nouvelle instruction au lancement de la macro : fichier joint.

 

[rtlv17]

Je n'arrive pas à adapter la macro vba de "job75", que je remercie pour ses efforts et tentatives pour m'expliquer sa solution.

Je propose de travailler sur le fichier, que je re transmets, du post#15 avec la solution proposée de "mapomme", cela me parait plus abordable en cas de modification.

Merci à tous pour votre aide.