Colorer l'aire entre 2 courbes sur graphique en Nuage de points

[job75]

Bonjour le forum,

Sur XLD ou le web il existe des solutions pour colorer l'aire entre 2 courbes quand il s'agit d'un graphique de type Courbes ou Aires.

Je n'en ai pas vu pour des graphiques en Nuage de points.

Cette solution est assez simple, elle détermine les points d'une 3ème série dans la feuille "Source" :

Sub ColorerDecolorer() 'bouton
If IsError(Application.Caller) Then Exit Sub
With ActiveSheet.DrawingObjects(Application.Caller)
  If .Text Like "Col*" Then
    ColorerAireEntreCourbes
  Else
    Sheets("Source").Range("A4:B" & Rows.Count).Delete xlUp 'conserver 1 point pour la mise en forme
  End If
  .Text = IIf(.Text Like "Col*", "Décolorer", "Colorer") & " l'aire entre les courbes"
End With
End Sub

Sub ColorerAireEntreCourbes()
Dim n&, x1, y1, x2, y2, deb, fin, e, x(), y(), i&, j&, a
n = 2000 'nombre de points
x1 = [X_1]: y1 = [Y_1]: x2 = [X_2]: y2 = [Y_2]
deb = Application.Max(Application.Min(x1), Application.Min(x2))
fin = Application.Min(Application.Max(x1), Application.Max(x2))
e = (fin - deb) / n
ReDim x(1 To n + 1, 1 To 1): ReDim y(1 To n + 1, 1 To 1)
For i = 1 To n Step 2
  x(i, 1) = deb + (i - 1) * e
  x(i + 1, 1) = x(i, 1)
  j = Application.Match(x(i, 1), x1)
  a = (y1(j + 1, 1) - y1(j, 1)) / (x1(j + 1, 1) - x1(j, 1))
  y(i, 1) = y1(j, 1) + a * (x(i, 1) - x1(j, 1))
  j = Application.Match(x(i, 1), x2)
  a = (y2(j + 1, 1) - y2(j, 1)) / (x2(j + 1, 1) - x2(j, 1))
  y(i + 1, 1) = y2(j, 1) + a * (x(i, 1) - x2(j, 1))
Next
With Sheets("Source").[A3].Resize(n)
  .Value = x
  .Name = "X"
End With
With Sheets("Source").[B3].Resize(n)
  .Value = y
  .Name = "Y"
End With
End Sub

Edit : ajouté + 1 pour la dimension des matrices x et y au cas où l'on mettrait un nombre impair pour n

A+

 

[job75]

Re : Colorer l'aire entre 2 courbes sur graphique en Nuage de points

Bonjour le forum,

Fichiers (2) avec une macro paramétrée :

Sub ColorerDecolorer() 'bouton
If IsError(Application.Caller) Then Exit Sub
With ActiveSheet.DrawingObjects(Application.Caller)
  If .Text Like "Col*" Then _
    ColorerAireEntreCourbes [X_1], [Y_1], [X_2], [Y_2] Else _
      Sheets("Source").Range("A4:B" & Rows.Count).Delete xlUp 'conserver 1 point pour la mise en forme
  .Text = IIf(.Text Like "Col*", "Décolorer", "Colorer") & " l'aire entre les courbes"
End With
End Sub

Sub ColorerAireEntreCourbes(x1, y1, x2, y2)
Dim n&, deb, fin, e, x(), y(), i&, j&, a
n = 2000 'nombre de points
x1 = x1: y1 = y1: x2 = x2: y2 = y2 'matrices, plus rapides
With Application: deb = .Max(.Min(x1), .Min(x2)): fin = .Min(.Max(x1), .Max(x2)): End With
e = (fin - deb) / n
ReDim x(1 To n + 1, 1 To 1): ReDim y(1 To n + 1, 1 To 1)
For i = 1 To n Step 2
  x(i, 1) = deb + (i - 1) * e
  x(i + 1, 1) = x(i, 1)
  j = Application.Match(x(i, 1), x1)
  a = (y1(j + 1, 1) - y1(j, 1)) / (x1(j + 1, 1) - x1(j, 1))
  y(i, 1) = y1(j, 1) + a * (x(i, 1) - x1(j, 1))
  j = Application.Match(x(i, 1), x2)
  a = (y2(j + 1, 1) - y2(j, 1)) / (x2(j + 1, 1) - x2(j, 1))
  y(i + 1, 1) = y2(j, 1) + a * (x(i, 1) - x2(j, 1))
Next
With Sheets("Source").[A3].Resize(n)
  .Value = x: .Columns(2).Value = y
  .Name = "X": .Columns(2).Name = "Y"
End With
End Sub

Bonne journée.

 

[mécano41]

Re : Colorer l'aire entre 2 courbes sur graphique en Nuage de points

Bonjour,

Merci pour cette solution.

Point de détail : en faisant passer "Aire" avant "Courbe1 et "Courbe2", on a une meilleure présentation

Cordialement

 

[job75]

Re : Colorer l'aire entre 2 courbes sur graphique en Nuage de points

Bonjour mécano41,

Bien vu et merci beaucoup, ça ne m'était pas venu à l'esprit et c'est très utile

Fichiers (3).

A+