Mapping

Bonjour,

Une piste avec le code suivant à copier dans un module standard.

Il donne, pour chaque point, la valeur et l'adresse de l'abscisse
ainsi que la valeur et l'adresse de l'ordonnée.

'*******************
Sub PMO_PointCoord()
Dim C As Chart
Dim P As Point
Dim i&
Dim j&
Dim bool As Boolean
Dim Adr$
Dim Feuil$
Dim A$
Dim R As Range
Dim Xvalue
Dim Yvalue
Dim Xaddress$
Dim Yaddress$
On Error GoTo Erreur
If TypeName(Selection) <> "ChartArea" Then
MsgBox prompt:="Vous avez sélectionné l'objet " & _
TypeName(Selection) & vbCrLf & vbCrLf & _
"Veuillez sélectionner un graphique", _
Title:="Erreur de sélection"
Exit Sub
End If
Set C = ActiveChart
If C.ChartType <> xlXYScatter Then Exit Sub
For i& = 1 To C.SeriesCollection.Count
bool = False
'---- Crée l'erreur 438 si les labels ne sont pas affichés ----
A$ = C.SeriesCollection(i&).Points(1).Text
'---- Les chaînes des sources ----
Adr$ = C.SeriesCollection(i&).Formula
Feuil$ = Adr$
'---- Nom de la feuille des sources des labels de la série ----
Feuil$ = Mid(Feuil$, 1, InStr(1, Feuil$, "!") - 1)
Feuil$ = Mid(Feuil$, InStr(1, Adr$, ",") + 1)
'---- Adresse des sources des labels de la série ----
Adr$ = Mid(Adr$, InStr(1, Adr$, "!") + 1)
Adr$ = Mid(Adr$, 1, InStr(1, Adr$, ",") - 1)
Set R = Sheets(Feuil$).Range(Adr$)
'---- Coordonnées et valeurs des points ----
For j& = 1 To C.SeriesCollection(i&).Points.Count
Set P = C.SeriesCollection(i&).Points(j&)
A$ = P.DataLabel.Text
Xvalue = Mid(A$, 1, InStr(1, A$, ",") - 1)
Yvalue = Mid(A$, InStr(1, A$, ",") + 1)
Xaddress$ = R.Cells(j&, 1).Address _
(RowAbsolute:úlse, ColumnAbsolute:úlse)
Yaddress$ = R.Cells(j&, 2).Address _
(RowAbsolute:úlse, ColumnAbsolute:úlse)
MsgBox "Série " & i& & vbCrLf & _
"Point " & j& & vbCrLf & vbCrLf & _
"Valeur de X = " & Xvalue & vbCrLf & _
"Adresse de X = " & Xaddress$ & vbCrLf & vbCrLf & _
"Valeur de Y = " & Yvalue & vbCrLf & _
"Adresse de Y = " & Yaddress$
Next j&
'---- Désaffiche éventuellement les labels ----
If bool Then C.SeriesCollection(i&).ApplyDataLabels _
ShowValue:úlse, ShowCategoryName:úlse
Next i&
Exit Sub
Erreur:
Select Case Err
Case 438
C.SeriesCollection(i&).ApplyDataLabels _
ShowValue:=True, ShowCategoryName:=True
bool = True
Err = 0
Resume Next
End Select
End Sub
'*******************

A vous de l'adapter à vos besoins.

Cordialement.
--
PMO
Patrick Morange

Je cherche la propriété...si elle existe me permettant de recuperer
les 2 cellules contenant les coordonnes de n'importe quel point d'un
mapping.
Ce serait un truc du style:
Set RngAbs¬tiveChart.SeriesCollection(1).Points(bytPoint).?????
Set
RngOrd=RngAbs¬tiveChart.SeriesCollection(1).Points(bytPoint).?????
Si qqun a deja rencontre et demasque ces ????? alors merci d'avance de
me montrer leur vrai visage.
Manu.