Macro - graphique - nuage de points

[arnaud_stutt]

Bonjour,

je voudrais creer un graphique composé d'une centaines de courbes (Nuages de points).

Les courbes n'ont pas le meme nombre de points, les ordonnées et abscisses sont aléatoires.

Est il possible de creer une boucle (macro) incrémentée sur les numeros de colonnes de manière à générer automatiquement ce graphique.

En piece jointe vous trouver un exemple de 32 ensembles de données (32 courbes). Je voudrais donc creer 32 nuages de point ou chaque deuxième colonne de chaque ensemble donne l'abscisses et chaque dernière colonne de chaque ensemble donne l'ordonnée.

Merci pour vos propositions

 

[PMO2]

Re : Macro - graphique - nuage de points

Bonjour,

Je me suis référé entièrement à votre exemple à savoir la ligne de départ des données est la ligne 5, la macro traite 32 ensembles
et fabrique, dans le même graphique, les 32 séries qui en dépendent.
Remarque : vos données sont en colonnes et chaque ensemble est constitué de 6 colonnes (5 pour les données plus 1 colonne de séparation).
Si vous voulez construire le graphique avec une centaine de séries cela ne marchera pas à cause de la limite 256 du nombre de colonnes Excel ???

Copiez le code suivant dans un module standard

'### Constante de la 1ère ligne (à adapter) ###
Const FIRST_LIG As Long = 5
'##############################################

Type StructAdresse
  Abs As String
  Ord As String
End Type

Sub SeriesNuage()
Dim S As Worksheet
Dim R As Range
Dim LastCol&
Dim LastLig&
Dim j&
Dim cpt&
Dim T() As StructAdresse
Dim CH As Chart
Dim A$
If TypeName(Selection) <> "Range" Then
  MsgBox "Veuillez sélectionner une cellule."
  Exit Sub
End If
On Error GoTo Erreur
'--- Adresse des séries ---
Set S = ActiveSheet
LastCol& = S.Range("iv" & FIRST_LIG & "").End(xlToLeft).Column
ReDim T(1 To (LastCol& + 1) / 6)
For j& = 2 To LastCol& Step 6
  Set R = S.Range(Cells(FIRST_LIG, j&), Cells(FIRST_LIG, j&))
  If Not IsEmpty(R.Offset(1, 0)) Then
    LastLig& = R.End(xlDown).Row
  Else
    LastLig& = FIRST_LIG
  End If
  cpt& = cpt& + 1
    '°°° Adresse des X °°°
  T(cpt&).Abs = S.Range(Cells(FIRST_LIG, j&), _
      Cells(LastLig&, j&)).Address(True, True, xlR1C1)
    '°°° Adresse des Y °°°
  T(cpt&).Ord = S.Range(Cells(FIRST_LIG, j& + 3), _
      Cells(LastLig&, j& + 3)).Address(True, True, xlR1C1)
Next j&
'--- Construction des séries ---
Application.ScreenUpdating = False
A$ = "=" & S.Name & "!"
Set CH = Charts.Add
CH.ChartType = xlXYScatterSmooth
For j& = 1 To UBound(T)
  CH.SeriesCollection.NewSeries
  CH.SeriesCollection(j&).XValues = A$ & T(j&).Abs
  CH.SeriesCollection(j&).Values = A$ & T(j&).Ord
Next j&
CH.Location Where:=xlLocationAsObject, Name:=S.Name
ActiveChart.Deselect
Erreur:
Application.ScreenUpdating = True
If Err <> 0 Then MsgBox "Erreur : " & Err.Number & vbCrLf & Err.Description
End Sub

Cordialement.

PMO
Patrick Morange