Réorganiser les données présentes dans un tableau

Le 13/01/2023 à 10:18

Bonjour,

Je viens chercher de l'aide auprès d'un problème pour lequel je ne vois pas trop par où commencer.

Concrètement, vous trouverez dans le fichier joint un tableau qui reprend la liste des cours donnés à certaines classe et/ou groupes classe par certains enseignants. Lors de la conception de ce tableau, nous devons essayer de ne pas mettre un même enseignant sur la même ligne sauf si celui donne cours à plusieurs groupes en même temps (Exemple de Dupont dans le fichier).

Ce que j'aimerais pouvoir obtenir à partir de ce tableau :

Lorsque je sélectionne le professeur dans la cellule AE6, le tableau du dessous se complète avec le cours qu'il donne avec l'heure (1ère colonne) ainsi que la (ou les) classes (pas besoin forcément du groupe) où le cours a lieu.

Je ne sais pas si c'est très clair et si ce n'est pas trop complexe. J'avais pensé à passer par Power Query mais le format est très limitant pour exploiter au mieux toutes les données. Peut-être qu'une remise en cause de la mise en forme pourrait aider. Je suis ouvert à toutes les propositions. A savoir, ce tableau est très souvent manipulé (suppression de case, ajout de colonne, ...).

Je ne maîtrise pas le VBA mais je suis à l'aise en codage de manière générale.

Merci en tout cas si vous prenez le temps de m'aider :-)

28test-alignement.xlsx (22.99 Ko)
Le 13/01/2023 à 17:17

Bonjour drmath4, le forum,

Un essai....pas optimisé...

10test-alignement.xlsm (30.10 Ko)

Cordialement,

Le 14/01/2023 à 09:41

Magnifique ! Mille mercis ! Il est donc temps que je me mette au VBA, la "simplicité" du code me fait rendre compte à quel point je suis nul :-p

Il me reste à adapter pour faire une conclusion sur plusieurs feuilles en même temps.

J'imagine qu'il doit être possible de concatener les les classes lorsque celles-ci ont le même prof et le même cours.

Le 20/01/2023 à 16:42

Bonjour à tous,

J'imagine qu'il doit être possible de concatener les les classes lorsque celles-ci ont le même prof et le même cours.

Un essai...

17drmath-v2.xlsm (33.81 Ko)

Cordialement,

Le 23/01/2023 à 11:14

Bonjour xorsankukai,

Je viens seulement de voir que vous aviez répondu à ma dernière question. Merci et désolé. J'ai un peu regardé de mon côté et j'ai changé changer de façon de travailler depuis le premier post.

Voici ce à quoi je suis arrivé pour compiler le tableau qui reprend une liste pour chaque professeur (plutôt qu'en en sélectionnant 1) :

16test-alignement-collecte.xlsm (36.92 Ko)

Maintenant l'idée est de rassembler les lignes qui ont les mêmes "Prof", "Matière", "Année" et "Heure" en faisant en sorte que les différences dans les colonnes "Classes" et "Groupes" soit concaténées seulement si elles sont différentes. Les 2 exemples de la feuille devraient aider à comprendre (j'espère :-p).

Voici le code sur lequel je me base pour générer le tableau :

Sub collecte_donnee()
 Dim dl%
 Application.ScreenUpdating = False

 With Sheets(1)

   dl = 2
   For i = 7 To 80 Step 2
    For y = 2 To 30
    gt = y

        If .Cells(i - 1, 1) <> 0 Then
            If .Cells(i, y) = 0 Then
                Do
                gt = gt - 1
                Loop While .Cells(i, gt) = 0
            End If
        End If

     If .Cells(i, gt) <> "" And .Cells(4, y) <> "" Then
      Worksheets(2).Cells(dl, 1) = .Cells(i, gt).Value
      Worksheets(2).Cells(dl, 2) = .Cells(i - 1, gt)
      Worksheets(2).Cells(dl, 3) = .Cells(1, gt).MergeArea.Cells(1, 1)
      Worksheets(2).Cells(dl, 4) = .Cells(4, y)
      Worksheets(2).Cells(dl, 5) = Sheets(1).Name
      Worksheets(2).Cells(dl, 6) = (i - 5) / 2

      dl = dl + 1
     End If
    Next y
   Next i
 End With
End Sub

J'ai bien vu votre proposition pour le fichier originale mais ne le comprenant pas tout à fait, je n'arrive pas à l'adapter ici. Si vous avez, une idée, je vous remercie d'avance pour votre aide :-)

Bonne journée.

Le 23/01/2023 à 16:44

Bonjour drmath4, le forum,

Après avoir pas mal galéré à cause de tes cellules fusionnées et ma maitrise approximative des dicos, voici un essai....à titre expérimental...

La macro s'exécute à l'activation de la feuille Synthèse.

Je te laisse le soin de vérifier la cohérence des résultats,

12collecte.xlsm (39.63 Ko)

Cordialement,

Le 23/01/2023 à 18:22

Merci ! Ca m'aide à bien avancer !

Néanmoins, j'ai du modifier un peu le code (que je ne comprends toujours pas tout à fait :-p) car les heures ne doivent pas être fusionnées.

Autre subtilité : à terme, je devrai faire ça avec 5 autres feuilles (1ère,3ème,4ème,5ème,6ème - il y a d'autres années, sinon ce ne serait pas drôle !) et tout compiler dans ce même tableau Synthèse. Du coup, je me demande si je ne suis pas mieux de compiler d'abord un premier tableau sans tri et d'effectuer le tri seulement une fois que toutes les années ont été répertoriées dans le tableau.

Dernières petites choses : J'ai rajouté un "/" pour faire la distinction entre groupe d'une même classe et une virgule pour séparé les groupes d'autres classes. Néanmoins, comment puis-je éviter la virgule ou le slash seul en fin ou début de cellule ?

J'espère être clair ^^ Voici le fichier et code mis à jour :

25collecte-v2.xlsm (43.06 Ko)
Sub recap()
 Dim dl%, ligne%, n%, i%, Ncol%, lig%, k%
 Dim dico, d1, d2, d3, d4, clé, clé2, clé3, clé4
 Dim t(), tb()

  Application.ScreenUpdating = False
   Set dico = CreateObject("Scripting.Dictionary")
   Set d1 = CreateObject("Scripting.Dictionary")
   Set d2 = CreateObject("Scripting.Dictionary")
   Set d3 = CreateObject("Scripting.Dictionary")
   Set d4 = CreateObject("Scripting.Dictionary")

 With Sheets("2ème")
   dl = 9
   ReDim t(1 To 200, 1 To 6)
     For y = 2 To 25
      For i = 7 To 25 Step 2
       If .Cells(i, y) <> "" Then
        col = .Cells(i, y).MergeArea.Columns.Count
        cl = .Cells(i, y).MergeArea.Column
         c = 1
         Do While c <= col
          groupe = groupe & "/" & .Cells(4, cl + c - 1)
         c = c + 1
         Loop
       n = n + 1
       t(n, 1) = .Cells(i, y) 'prof
       t(n, 2) = .Cells(i - 1, y) 'matière
       t(n, 3) = .Cells(1, y).MergeArea.Cells(1, 1) 'classe
       t(n, 4) = t(n, 4) & groupe: groupe = "" 'groupe
       t(n, 5) = .Name 'année
       t(n, 6) = .Cells(i - 1, 1) 'heure
       End If
     Next i
    Next y

   If n > 0 Then
    Ncol = 6
     ReDim tb(1 To UBound(t), 1 To Ncol)
      For ligne = 1 To UBound(t)
       clé = t(ligne, 1) & "|" & t(ligne, 2) & "|" & t(ligne, 6)
        If d1.exists(clé) Then
         lig = d1(clé)
        Else
         d1(clé) = d1.Count + 1: lig = d1.Count
         tb(lig, 1) = t(ligne, 1) 'prof
         tb(lig, 2) = t(ligne, 2) 'matière
         tb(lig, 5) = .Name 'année
         tb(lig, 6) = t(ligne, 6) 'heure
        End If

        clé2 = t(ligne, 1) & "|" & t(ligne, 2) & "|" & t(ligne, 5) & "|" & t(ligne, 6) & "|" & t(ligne, 3)
         If Not d2.exists(clé2) Then
          tb(lig, 3) = tb(lig, 3) & t(ligne, 3) & " ,": d2(clé2) = "" 'classe
         End If

       clé3 = t(ligne, 1) & "|" & t(ligne, 2) & "|" & t(ligne, 5) & "|" & t(ligne, 6) & "|" & t(ligne, 4)
        If Not d3.exists(clé3) Then
         tb(lig, 4) = tb(lig, 4) & t(ligne, 4) & " ,": d3(clé3) = "" 'groupe
        End If

      Next ligne
   End If
 End With

 With Sheets("Synthèse")
  If Not .ListObjects(1).DataBodyRange Is Nothing Then .ListObjects(1).DataBodyRange.Delete
  .ListObjects(1).InsertRowRange.Cells(1).Resize(d1.Count - 1, Ncol) = tb
  .ListObjects(1).Sort.SortFields.Clear
  .ListObjects(1).ListColumns(1).Range.Sort Key1:=.ListObjects(1).HeaderRowRange.Cells(1, 1), Header:=xlYes
  .Columns.AutoFit
  .Activate
 End With
End Sub
Le 23/01/2023 à 21:16

Bonsoir à tous,

Je réponds à ceci :

Maintenant l'idée est de rassembler les lignes qui ont les mêmes "Prof", "Matière", "Année" et "Heure" en faisant en sorte que les différences dans les colonnes "Classes" et "Groupes" soit concaténées seulement si elles sont différentes.

drmath4, je me suis basé sur la feuille Recap pour fusionner vos lignes, c'est bien ça.

Donc pas de doublons en colonnes Classes et groupes, on forme la clé du dictionnaire avec les éléments des colonnes Prof, Matière, Année et Heure.

Option Explicit
Sub Fusion()
    Dim a, b(), i As Long, txt As String
    a = Sheets("Recap").Cells(1).CurrentRegion.Value
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
    b(1, 1) = a(1, 1): b(1, 2) = a(1, 2): b(1, 3) = a(1, 3)
    b(1, 4) = a(1, 4): b(1, 5) = a(1, 5): b(1, 6) = a(1, 6)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            txt = Join(Array(a(i, 1), a(i, 2), a(i, 5), a(i, 6)), Chr(2))
            If Not .exists(txt) Then
                b(.Count + 2, 1) = a(i, 1): b(.Count + 2, 2) = a(i, 2)
                b(.Count + 2, 5) = a(i, 5): b(.Count + 2, 6) = a(i, 6)
                .Item(txt) = Array(.Count + 2, CreateObject("Scripting.Dictionary"), _
                                               CreateObject("Scripting.Dictionary"))
                .Item(txt)(1).CompareMode = 1: .Item(txt)(2).CompareMode = 1
            End If
            If Not .Item(txt)(1).exists(a(i, 3)) Then
                b(.Item(txt)(0), 3) = b(.Item(txt)(0), 3) & _
                IIf(b(.Item(txt)(0), 3) <> "", ",", "") & a(i, 3)
                .Item(txt)(1)(a(i, 3)) = Empty
            End If
            If Not .Item(txt)(2).exists(a(i, 4)) Then
                b(.Item(txt)(0), 4) = b(.Item(txt)(0), 4) & _
                IIf(b(.Item(txt)(0), 4) <> "", ",", "") & a(i, 4)
                .Item(txt)(2)(a(i, 4)) = Empty
            End If
        Next
        i = .Count + 1
    End With
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Cells(1).Resize(i, 6) 'restitution
       .CurrentRegion.Clear
       .Value = b
       With .Font
         .Name = "calibri"
         .Size = 10
       End With
       .VerticalAlignment = xlCenter
       .Borders(xlInsideVertical).Weight = xlThin
       .BorderAround Weight:=xlThin
       With .Rows(1)
         .BorderAround Weight:=xlThin
         .Interior.ColorIndex = 40
       End With
    End With
    Application.ScreenUpdating = True
End Sub

Restitution dans une feuille nommée Feuil1.

On doit pouvoir obtenir le même résultat avec Power Query non !

klin89

Le 24/01/2023 à 17:53

Bonsoir à tous,

@Klin89:

Je suis admiratif de ta maitrise des dictionnaires, je constate qu'il me reste encore beaucoup de travail pour les maitriser convenablement,

Tu as traité à partir de la feuille Recap, peux-tu effectuer ce même traitement directement à partir de la feuille 2ème ?

@drmath4 :

A partir de ton dernier fichier,

Si j'arrivais bien à supprimer le dernier caractère de groupe à partir du dico, je n'y suis pas parvenu pour classe (), aussi, j'ai donc rajouté une boucle:

Option Explicit
Sub recap()
 Dim ligne%, n%, i%, y%, lig%
 Dim Ncol%, col%, cl%, c%
 Dim d1, d2, d3, d4, clé1, clé2, clé3
 Dim groupe$
 Dim t(), tb()

  Application.ScreenUpdating = False
   Set d1 = CreateObject("Scripting.Dictionary")
   Set d2 = CreateObject("Scripting.Dictionary")
   Set d3 = CreateObject("Scripting.Dictionary")
     Ncol = 6

 With Sheets("2ème")
   ReDim t(1 To .UsedRange.Rows.Count * Ncol, 1 To Ncol)
     For y = 2 To 25
      For i = 7 To 25 Step 2
       If .Cells(i, y) <> "" Then
        col = .Cells(i, y).MergeArea.Columns.Count
        cl = .Cells(i, y).MergeArea.Column
         c = 1
         Do While c <= col
          groupe = groupe & .Cells(4, cl + c - 1) & "/"
         c = c + 1
         Loop
       n = n + 1
       t(n, 1) = .Cells(i, y) '...........................prof
       t(n, 2) = .Cells(i - 1, y) '.......................matière
       t(n, 3) = .Cells(1, y).MergeArea.Cells(1, 1) '.....classe
       t(n, 4) = groupe: groupe = ""  '...................groupe
       t(n, 5) = .Name '..................................année
       t(n, 6) = .Cells(i - 1, 1) '.......................heure
       End If
     Next i
    Next y

   If n > 0 Then
     ReDim tb(1 To UBound(t), 1 To Ncol)
      For ligne = 1 To UBound(t)
       clé1 = t(ligne, 1) & "|" & t(ligne, 2) & "|" & t(ligne, 6)
        If d1.exists(clé1) Then
         lig = d1(clé1)
        Else
         d1(clé1) = d1.Count + 1: lig = d1.Count
         tb(lig, 1) = t(ligne, 1) '......................prof
         tb(lig, 2) = t(ligne, 2) '......................matière
         tb(lig, 5) = .Name '............................année
         tb(lig, 6) = t(ligne, 6) 'heure
        End If

        clé2 = t(ligne, 1) & "|" & t(ligne, 2) & "|" & t(ligne, 5) & "|" & t(ligne, 6) & "|" & t(ligne, 3)
         If Not d2.exists(clé2) Then
          tb(lig, 3) = tb(lig, 3) & t(ligne, 3) & " ,": d2(clé2) = "" 'classe
         End If

       clé3 = t(ligne, 1) & "|" & t(ligne, 2) & "|" & t(ligne, 5) & "|" & t(ligne, 6) & "|" & t(ligne, 4)
        If Not d3.exists(clé3) Then
         tb(lig, 4) = tb(lig, 4) & t(ligne, 4): d3(clé3) = ""  'groupe
        End If
      Next ligne
   End If
 End With

 With Sheets("Synthèse")
   With .ListObjects(1)
    If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
    .InsertRowRange.Cells(1).Resize(d1.Count - 1, Ncol) = tb
    .Sort.SortFields.Clear
    .ListColumns(1).Range.Sort Key1:=.HeaderRowRange.Cells(1, 1), Header:=xlYes
    For lig = 1 To .ListRows.Count
    .DataBodyRange(lig, 3) = Left(.DataBodyRange(lig, 3), Len(.DataBodyRange(lig, 3)) - 1) 'retire la dernière , de classe
    .DataBodyRange(lig, 4) = Left(.DataBodyRange(lig, 4), Len(.DataBodyRange(lig, 4)) - 1) 'retire le dernier / de groupe
    Next lig
   End With
  .Columns.AutoFit
  .Activate
 End With
End Sub

Comme tu n'as pas énormément de lignes, le temps d'exécution ne devrait pas être impacté.

[EDIT]

16collecte-v3.xlsm (42.91 Ko)

Cordialement,

Le 24/01/2023 à 22:28

Re xorsankukai,

Dans le code précédent, le dictionnaire enfant nous permet de tester la présence des doublons en colonnes Classes et Groupes pour les supprimer.

Le code suivant délesté de ces 2 dictionnaires laisse apparaître les doublons.

Option Explicit
Sub Fusion1()
    Dim a, b(), i As Long, txt As String
    a = Sheets("Recap").Cells(1).CurrentRegion.Value
    ReDim b(1 To UBound(a, 1), 1 To UBound(a, 2))
    b(1, 1) = a(1, 1): b(1, 2) = a(1, 2): b(1, 3) = a(1, 3)
    b(1, 4) = a(1, 4): b(1, 5) = a(1, 5): b(1, 6) = a(1, 6)
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            txt = Join(Array(a(i, 1), a(i, 2), a(i, 5), a(i, 6)), Chr(2))
            If Not .exists(txt) Then
                b(.Count + 2, 1) = a(i, 1): b(.Count + 2, 2) = a(i, 2)
                b(.Count + 2, 5) = a(i, 5): b(.Count + 2, 6) = a(i, 6)
                .Item(txt) = .Count + 2
            End If
            b(.Item(txt), 3) = b(.Item(txt), 3) & _
                IIf(b(.Item(txt), 3) <> "", ",", "") & a(i, 3)
            b(.Item(txt), 4) = b(.Item(txt), 4) & _
                IIf(b(.Item(txt), 4) <> "", ",", "") & a(i, 4)
        Next
        i = .Count + 1
    End With
    Application.ScreenUpdating = False
    With Sheets("Feuil1").Cells(1).Resize(i, 6) 'restitution
       .CurrentRegion.Clear
       .Value = b
       With .Font
         .Name = "calibri"
         .Size = 10
       End With
       .VerticalAlignment = xlCenter
       .Borders(xlInsideVertical).Weight = xlThin
       .BorderAround Weight:=xlThin
       With .Rows(1)
         .BorderAround Weight:=xlThin
         .Interior.ColorIndex = 40
       End With
    End With
    Application.ScreenUpdating = True
End Sub

Quand on compare les 2 codes, c'est assez simple à comprendre finalement.

klin89

Le 26/01/2023 à 11:55

Bonjour à tous,

Merci pour vos retours. J'ai un peu trituré vos 2 propositions et au final, je m'en suis un peu mieux sorti avec le code de xorsankukai.

Du coup, il fait bien tout ce que je veux faire mais j'ai eu une nouvelle idée de colonnes pour laquelle j'ai évidemment un problème (Ben tiens ! :-D)

La nouvelle colonne donne le nombre total d'élève devant le prof. Je me suis basé sur les lignes qui géraient les groupes puisque ces 2 infos sont liées mais sans succès. Pourriez-vous m'aider à trouver le problème dans mon code ? (Il marche pour certains profs/matières mais pas pour tous. Exemple : Dupond en Socio-Eco en heure 1)

14collecte-v4.xlsm (38.21 Ko)
Sub collecte_donnees()

 Dim ligne%, n%, i%, y%, lig%, eleve%
 Dim Ncol%, col%, cl%, c%
 Dim d1, d2, d3, d4, clé1, clé2, clé3, clé4
 Dim groupe$
 Dim t(), tb()
 Dim k As Long
 Application.ScreenUpdating = False

   Set d1 = CreateObject("Scripting.Dictionary")
   Set d2 = CreateObject("Scripting.Dictionary")
   Set d3 = CreateObject("Scripting.Dictionary")
   Set d4 = CreateObject("Scripting.Dictionary")

   Ncol = 7
   eleve = 0

 With Sheets(1)
   ReDim t(1 To .UsedRange.Rows.Count * Ncol, 1 To Ncol)
     For y = 2 To 52
      For i = 7 To 80 Step 2
       If .Cells(i, y) <> "" Then
        col = .Cells(i, y).MergeArea.Columns.Count
        cl = .Cells(i, y).MergeArea.Column
         c = 1
         Do While c <= col
          groupe = groupe & .Cells(4, cl + c - 1) & ", "
          eleve = eleve + .Cells(5, cl + c - 1).Value
         c = c + 1
         Loop
       n = n + 1
       t(n, 1) = .Cells(i, y) '...........................prof
       t(n, 2) = .Cells(i - 1, y) '.......................matière
       t(n, 3) = .Cells(1, y).MergeArea.Cells(1, 1) '.....classe
       t(n, 4) = groupe: groupe = ""  '...................groupe
       t(n, 5) = .Name '..................................année
       t(n, 6) = .Cells(i - 1, 1) '.......................heure
       t(n, 7) = eleve: eleve = 0 '...................nombre d'élèves
       End If
     Next i
    Next y

   If n > 0 Then
     ReDim tb(1 To UBound(t), 1 To Ncol)
      For ligne = 1 To UBound(t)
       clé1 = t(ligne, 1) & "|" & t(ligne, 2) & "|" & t(ligne, 6)
        If d1.exists(clé1) Then
         lig = d1(clé1)
        Else
         d1(clé1) = d1.Count + 1: lig = d1.Count
         tb(lig, 1) = t(ligne, 1) '......................prof
         tb(lig, 2) = t(ligne, 2) '......................matière
         tb(lig, 5) = .Name '............................année
         tb(lig, 6) = t(ligne, 6) 'heure
        End If

        clé2 = t(ligne, 1) & "|" & t(ligne, 2) & "|" & t(ligne, 5) & "|" & t(ligne, 6) & "|" & t(ligne, 3)
         If Not d2.exists(clé2) Then
          tb(lig, 3) = tb(lig, 3) & t(ligne, 3) & ", ": d2(clé2) = "" 'classe
         End If

       clé3 = t(ligne, 1) & "|" & t(ligne, 2) & "|" & t(ligne, 5) & "|" & t(ligne, 6) & "|" & t(ligne, 4)
        If Not d3.exists(clé3) Then
         tb(lig, 4) = tb(lig, 4) & t(ligne, 4): d3(clé3) = ""  'groupe
        End If

       clé4 = t(ligne, 1) & "|" & t(ligne, 2) & "|" & t(ligne, 5) & "|" & t(ligne, 6) & "|" & t(ligne, 7)
        If Not d4.exists(clé4) Then
         tb(lig, 7) = tb(lig, 7) + t(ligne, 7): d4(clé4) = 0 'Nb élèves
        End If

      Next ligne
   End If
 End With

 With Sheets("Recap Profs")
   With .ListObjects(1)
    If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
    .InsertRowRange.Cells(1).Resize(d1.Count - 1, Ncol) = tb
    .Sort.SortFields.Clear
    .ListColumns(1).Range.Sort Key1:=.HeaderRowRange.Cells(1, 6), Header:=xlYes
    For lig = 1 To .ListRows.Count
    .DataBodyRange(lig, 3) = Left(.DataBodyRange(lig, 3), Len(.DataBodyRange(lig, 3)) - 2) 'retire la dernière , de classe
    .DataBodyRange(lig, 4) = Left(.DataBodyRange(lig, 4), Len(.DataBodyRange(lig, 4)) - 2) 'retire le dernier / de groupe
    Next lig
   End With
  .Columns.AutoFit
  .Activate
 End With
End Sub

Merci !

Le 27/01/2023 à 09:25

Bonjour à tous,

A tester:

Sub collecte_donnees()
 Dim ligne%, n%, i%, y%, lig%, eleve%
 Dim Ncol%, col%, cl%, c%
 Dim d1, d2, d3, clé1, clé2, clé3
 Dim groupe$
 Dim t(), tb()
 Dim k As Long

 Application.ScreenUpdating = False

   Set d1 = CreateObject("Scripting.Dictionary")
   Set d2 = CreateObject("Scripting.Dictionary")
   Set d3 = CreateObject("Scripting.Dictionary")

    Ncol = 7
   eleve = 0

 With Sheets(1)
   ReDim t(1 To .UsedRange.Rows.Count * Ncol, 1 To Ncol)
     For y = 2 To 25
      For i = 7 To 25 Step 2
       If .Cells(i, y) <> "" Then
        col = .Cells(i, y).MergeArea.Columns.Count
         cl = .Cells(i, y).MergeArea.Column
          c = 1
         Do While c <= col
          groupe = groupe & .Cells(4, cl + c - 1) & ", "
          eleve = eleve + .Cells(5, cl + c - 1).Value
         c = c + 1
         Loop
       n = n + 1
       t(n, 1) = .Cells(i, y) '...........................prof
       t(n, 2) = .Cells(i - 1, y) '.......................matière
       t(n, 3) = .Cells(1, y).MergeArea.Cells(1, 1) '.....classe
       t(n, 4) = groupe: groupe = ""  '...................groupe
       t(n, 5) = .Name '..................................année
       t(n, 6) = .Cells(i - 1, 1) '.......................heure
       t(n, 7) = eleve: eleve = 0 '.......................nombre d'élèves
       End If
     Next i
    Next y

   If n > 0 Then
     ReDim tb(1 To UBound(t), 1 To Ncol)
      For ligne = 1 To UBound(t)
       clé1 = t(ligne, 1) & "|" & t(ligne, 2) & "|" & t(ligne, 6)
        If d1.exists(clé1) Then
         lig = d1(clé1)
        Else
         d1(clé1) = d1.Count + 1: lig = d1.Count
         tb(lig, 1) = t(ligne, 1) '......................prof
         tb(lig, 2) = t(ligne, 2) '......................matière
         tb(lig, 5) = .Name '............................année
         tb(lig, 6) = t(ligne, 6) '......................heure
        End If

        clé2 = t(ligne, 1) & "|" & t(ligne, 2) & "|" & t(ligne, 5) & "|" & t(ligne, 6) & "|" & t(ligne, 3)
         If Not d2.exists(clé2) Then
          tb(lig, 3) = tb(lig, 3) & t(ligne, 3) & ", ": d2(clé2) = "" 'classe
         End If

       clé3 = t(ligne, 1) & "|" & t(ligne, 2) & "|" & t(ligne, 5) & "|" & t(ligne, 6) & "|" & t(ligne, 4)
        If Not d3.exists(clé3) Then
         tb(lig, 4) = tb(lig, 4) & t(ligne, 4): d3(clé3) = ""  'groupe
        End If

       tb(lig, 7) = tb(lig, 7) + t(ligne, 7)

      Next ligne
   End If
 End With

 With Sheets("Recap Profs")
   With .ListObjects(1)
    If Not .DataBodyRange Is Nothing Then .DataBodyRange.Delete
    .InsertRowRange.Cells(1).Resize(d1.Count - 1, Ncol) = tb
    .Sort.SortFields.Clear
    .ListColumns(1).Range.Sort Key1:=.HeaderRowRange.Cells(1, 6), Header:=xlYes
    For lig = 1 To .ListRows.Count
    .DataBodyRange(lig, 3) = Left(.DataBodyRange(lig, 3), Len(.DataBodyRange(lig, 3)) - 2) 'retire la dernière , de classe
    .DataBodyRange(lig, 4) = Left(.DataBodyRange(lig, 4), Len(.DataBodyRange(lig, 4)) - 2) 'retire le dernier / de groupe
    Next lig
   End With
  .Columns.AutoFit
  .Activate
 End With
End Sub

J'ai supprimé le dictionnaire d4....

Cordialement,

Le 27/01/2023 à 11:02

Magnifique ! Ça m'a l'air de bien fonctionné :-)
Merci !

Rechercher des sujets similaires à "reorganiser donnees presentes tableau"