Re : Le Barbatruc de Jam: Un graph dans une cellule.
Bonjour,
Désolé Wilfried, mais je n'ai absolument rien compris...
Aucune idée où exactement placer cette modification (2ème ligne ??? Oui, mais c'est quoi la 2ème ligne ??? Après Sub, après Dim ???).
Bon, je ne suis absolument pas expert en macros et autres fonctions....
Mais si tu m'adressais intégralement ta fonction...
En revanche je m'escrime, toujours sans succés à 100%, à tenter d'améliorer cette fonction hallucinante (pour ceux qui aiment encore ça...).
Le problème majeur de cette fonction est que nous sommes assujettis à une seule cellule. Si les coordonnées de la courbe sont très nombreuses, le graphique risque d'être très ramassé, à moins que l'on élargisse la cellule avec toutes les conséquence sur l'aspect de la feuille (d'un seul coup une cellule géante !!). Donc, la solution idéale serait de pouvoir moduler le nombre de colonnes et de lignes sur lesquelles viendrait se juxtaposer le graphique.
J'ai "bidouillé" à nouveau la fonction pour au moins résoudre, dans un premier temps, le problème des colonnes (la largeur du graphique me paraissant plus importante que la hauteur). Voici la fonction avec nombre de commentaires :
Function LineChart(Points As Range, colonnes%, Lignes%, Optional ByVal Couleur%) '2 variables supplémentaires : colonnes(%) et Lignes(%)
'Une fonction de Rob Van Gelder un peu modifiée par Ti, Chris & Magic_Doctor
Const KMg = 2, KTag = "Line"
Dim ref As Range, ShRg(), Bcle&, Cnt&
Dim Min#, Max#, Pts, Lg#, Ht#
Dim i%, largeurColonne, largeurColonnesSup, facteur 'variables rajoutées pour les besoins des calculs
On Error Resume Next
With Points
If .Rows.Count > 1 And .Columns.Count > 1 Then
LineChart = CVErr(xlErrValue): Exit Function
End If
Pts = .Value: Cnt = .Count
ReDim ShRg(1 To Cnt - 1)
If .Columns.Count > 1 Then Pts = WorksheetFunction.Transpose(Pts)
End With
'-------------------------------- RAJOUTS -------------------------------------------
'soit il y a une seule colonne, soit plusieurs
If colonnes > 1 Then 's'il y a plusieurs colonnes (<=> plusieurs cellules contiguës)
'vérifie si toutes les colonnes ont la même largeur
For i% = 0 To colonnes% - 1
If ActiveCell.Offset(0, i%).ColumnWidth = ActiveCell.ColumnWidth Then 'si toute les colonnes ont la même largeur
largeurColonne = largeurColonne + 0 '(le résultat sera nul)
Else 'si toute les colonnes n'ont pas la même largeur
largeurColonne = largeurColonne + 1 '(le résultat sera le nb de colonnes dont la largeur est # de la 1ère)
End If
Next i%
If largeurColonne = 0 Then 'les colonnes ont toutes la même largeur
facteur = 1
Else 'les colonnes n'ont pas toutes la même largeur, on cherche alors un facteur de correction
'calcul de la somme des largeurs des colonnes excédentaires (puisque à l'origine, il n'y avait qu'une seule colonne)
For i% = 1 To colonnes - 1
largeurColonnesSup = largeurColonnesSup + ActiveCell.Offset(0, i%).ColumnWidth
Next i%
facteur = 1 + largeurColonnesSup / ActiveCell.ColumnWidth ^ 2 'tentative algorithme découlant de l'incontournable règle de 3, mais sujet à caution...
End If
Else 's'il n'y a qu'une seule colonne (<=> une cellule unique, comme dans la fonction originale)
facteur = 1
End If
'------------------------------------------------------------------------------------
Set ref = Application.Caller
With ref
.Worksheet.Shapes(KTag & .Address).Delete
Min = WorksheetFunction.Min(Pts)
Max = WorksheetFunction.Max(Pts)
Lg = (.Width - (KMg * 2)) / (Cnt - 1) * colonnes * facteur 'on multiplie Lg par [le nb de colonnes] * [facteur de correction] pour obtenir la largeur de l'ensemble des cellules
'Lg = ActiveCell.ColumnWidth * colonnes * facteur
Ht = (.Height - (KMg * 2)) / (Max - Min) * Lignes
For Bcle = 1 To Cnt - 1
With .Worksheet.Shapes.AddLine( _
KMg + .Left + Lg * (Bcle - 1), _
KMg + .Top + (Max - Pts(Bcle, 1)) * Ht, _
KMg + .Left + Lg * Bcle, _
KMg + .Top + (Max - Pts(Bcle + 1, 1)) * Ht)
ShRg(Bcle) = .Name
End With
Next Bcle
With .Worksheet.Shapes.Range(ShRg)
.Group
.Line.ForeColor.SchemeColor = Couleur
.Name = KTag & ref.Address
End With
End With
LineChart = ""
End Function
Copiez/Collez dans un module et testez.
Il y a une certaine amélioration dans la largeur du graphique, mais ce n'est pas encore ça...
La largeur du graphique ne correspond pas forcément au nombre de colonnes (autrement dit cellules contiguës) choisi.
Mais enfin, ça progresse !
Si cette fonction intéresse encore quelqu'un, toute suggestion sera la bienvenue.
