Ci-joint un fichier excel pour illustrer ma question.
Je souhaiterais à partir des données contenue dans l’onglet Données obtenir les tableaux contenus dans l’onglet resultat en sachant que le nombre de classe, de matière et d’enseignant est variable.
Avec un simple Tableau Croisé Dynamique, on arrive sensiblement au même résultat
Sinon, c’est passer par du VBA et avec les cellules fusionnées, c’est plus la même
En fait je souhaite vraiment avoir la vue tel que définie dans le tableau en A4:D8.
Je me doutais que la macro allait etre nécessaire d’ou ma demande d’aide.
Sub Regroupe()
Application.ScreenUpdating = False
'Déclaration des variables
Set F = Sheets("Données")
BD = F.Range("A2:D" & F.[A65000].End(xlUp).Row).Value
colCrit1 = 1
colCrit2 = 2
colCrit3 = 3
colCrit4 = 4
Set Result = Sheets("Resultat").Range("A4")
'Boucle sur les colonnes
For i = LBound(BD) To UBound(BD)
BD(i, colCrit4) = F.Cells(i + 1, colCrit3).Font.ColorIndex
Next i
'Vide la feuille Resultat
Result.CurrentRegion.ClearContents
'Déclaration des dictionnaires (rapidité)
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
'Boucle sur les résultats des dicos
For i = LBound(BD) To UBound(BD)
tmp = BD(i, colCrit2): If d1.exists(tmp) Then lig = d1(tmp) Else d1(tmp) = d1.Count + 1: lig = d1.Count
tmp = BD(i, colCrit1): If d2.exists(tmp) Then col = d2(tmp) Else d2(tmp) = d2.Count + 1: col = d2.Count
x = Len(Result.Offset(lig, col))
Result.Offset(lig, col).Characters(Start:=x + 1, Length:=1).Text = BD(i, colCrit3) & Chr(10)
Next i
'Recopie des données dans la feuille Résultat
Result.Offset(1).Resize(d1.Count) = Application.Transpose(d1.keys)
Result.Offset(, 1).Resize(, d2.Count) = d2.keys
Sheets("Resultat").Activate
End Sub
Désolée pour la confusion et le dédoublement de personalité.
J’ai posé ma question avant de m’inscrire donc sans choisir le pseudo et en voulant te repondre j’en ai choisi un.
Donc désormais je suis et reste natie.
Merci pour ton aide je teste ta macro ca sur mon fichier de 3000 lignes et te tiens au courant
Je te remercie pour ta macro et j’aurais à nouveau besoin de ton aide.
En effet, je dois utiliser cette macro sur Excel 2007 or la ligne
Result.Offset(lig, col).Characters(Start:=x + 1, Length:=1).Text = BD(i, colCrit3) & Chr(10)
me renvoie le message d’erreur “Impossible de définir la propriété Text de la classe Characters” (alors que cela fonctionne tres bien sur excel 365).
Merci de ton aide (ca fait 4 jours que je me tords la tete avec cette macro et pas que sur ce point.)
Bon je ne m’y connais pas autant que @Mimimathy en VBA, mais j’ai peut-être trouvé une solution.
A tester:
Remplace Chr(10) par vbCrLf ça a l’air de fonctionner.
Code modifié:
Sub Regroupe()
Application.ScreenUpdating = False
'Déclaration des variables
Set F = Sheets("Données")
BD = F.Range("A2:D" & F.[A65000].End(xlUp).Row).Value
colCrit1 = 1
colCrit2 = 2
colCrit3 = 3
colCrit4 = 4
Set Result = Sheets("Resultat").Range("A4")
'Boucle sur les colonnes
For i = LBound(BD) To UBound(BD)
BD(i, colCrit4) = F.Cells(i + 1, colCrit3).Font.ColorIndex
Next i
'Vide la feuille Resultat
Result.CurrentRegion.ClearContents
'Déclaration des dictionnaires (rapidité)
Set d1 = CreateObject("Scripting.Dictionary")
Set d2 = CreateObject("Scripting.Dictionary")
'Boucle sur les résultats des dicos
For i = LBound(BD) To UBound(BD)
tmp = BD(i, colCrit2): If d1.exists(tmp) Then lig = d1(tmp) Else d1(tmp) = d1.Count + 1: lig = d1.Count
tmp = BD(i, colCrit1): If d2.exists(tmp) Then col = d2(tmp) Else d2(tmp) = d2.Count + 1: col = d2.Count
x = Len(Result.Offset(lig, col))
Result.Offset(lig, col).Characters(Start:=x + 1, Length:=1).Text = BD(i, colCrit3) & vbCrLf 'Chr(10)
Next i
'Recopie des données dans la feuille Résultat
Result.Offset(1).Resize(d1.Count) = Application.Transpose(d1.keys)
Result.Offset(, 1).Resize(, d2.Count) = d2.keys
Sheets("Resultat").Activate
End Sub
Merci pour votre solution.
Je vous aurais bien mon fichier initial mais il est lié à plusieurs autres fichiers et comporte de nombreuses macros ; il fait à peu pres 25 Mo sans les fichiers annexes.
Malheuresement je ne suis plus au bureau donc impossible de verifier votre solution (je n’ai que office 365 chez moi)
Le message d’erreur s’affiche lorsque la boucle essaie d’ajouter à une même cellule trop de lignes (ou caractères ?)
En effet, je peux avoir à ajouter jusqu’à 20 lignes dont chacune peut faire jusqu’à 50 caractères.
Une idée qui permettrait de tester à la maison sans installer une autre version Excel ?
Je dois rendre le fichier final demain matin et je désespere…
Pour information j’ai reussi à contourner la limitation en modifiant la macro de cette maniere :
Dim char As String
For i = LBound(BD) To UBound(BD)
tmp = BD(i, colCrit1): If d1.exists(tmp) Then lig = d1(tmp) Else d1(tmp) = d1.Count + 1: lig = d1.Count
tmp = BD(i, colCrit1): If d2.exists(tmp) Then col = d2(tmp) Else d2(tmp) = d2.Count + 1: col = d2.Count
char = Result.Offset(lig, col).Value
char = BD(i, colCrit6) & vbCrLf & char
Result.Offset(lig, col).Value = char
Next i