EXCEL XY SCATTER CHART?

如何在EXCEL 的XY SCATTER CHART中加入第三軸?其中兩軸為數值軸, 一個為序列軸. 多謝幫助!!!

回復 1# dust2bin

找到一個3D SCATTER CHART的VB MACRO. 可用. 若有不妥, 請高手指正. 多謝.

Sub Make3DscatterplotFromDataRange()
'
' DefineName Makro
' Makro am 29.9.2006 von gd aufgezeichnet
'
' this macro draws dynamic 3d scatterplots from a selected range
' macro assumes pure data range (3 columns x,y,z) is selected
' if 4 columns are selected, macro assumes he first column contains text for data labels
' and that 10 rows above that range a free to use for rotational and cut plane parameters

Randomize (Timer)

CN$ = Chr$(Rnd() * 25 + 65) & Chr$(Rnd() * 25 + 65) & Chr$(Rnd() * 25 + 65) ' ID name for sereis and defined names

CN$ = InputBox("Enter a identifying name for this data", "Name for data", CN$)

' replace special characters not allowed in names, which are !"#$%&'()*+,-/:;<=>@[]^_`{}~
' underscores are replaced too
For Each xxi In Array(32, 33, 34, 35, 36, 37, 38, 39, 40, 41, 42, 43, 44, 45, 47, 58, 59, 60, 61, 62, 64, 91, 93, 94, 95, 96, 123, 125, 126, 127)
    CN$ = Application.WorksheetFunction.Substitute(CN$, Chr$(xxi), "")
Next
For xxi = 128 To 255
    CN$ = Application.WorksheetFunction.Substitute(CN$, Chr$(xxi), "")
Next xxi

Set sel = Selection

leftsel = sel.Cells(1, 1).Left
topsel = sel.Cells(1, 1).Top - 1

dlb = 0 ' flag for data labels
If sel.Columns.Count > 3 Then dlb = 1

Application.ScreenUpdating = False

'determine if color transparency can be set
trcap = 1 ' flag for transparent color capability
With ActiveSheet.Shapes.AddShape(msoShapeOval, 2, 2, 20, 20)
    On Error GoTo notrsp
    .Fill.Transparency = 0.5
    On Error GoTo 0
GoTo trsp:
notrsp: trcap = 0
trsp:
    .Delete
End With



' create sliders for user control:
sel.Cells(1, 1).Offset(-4, -1).Value = "angles" ' caption
' scroll bar for rotation around x
sel.Cells(1, 1).Offset(-10, -1).Value = "rotate x" ' caption
ActiveSheet.ScrollBars.Add(leftsel, topsel - 10 * 13, 260, 16).Select
adr$ = sel.Cells(1, 1).Offset(-4, 0).Address
    With Selection
        .Min = 0
        .Max = 360
        .Value = 120
        .SmallChange = 1
        .LargeChange = 10
        .LinkedCell = adr$
    End With
ActiveWorkbook.Names.Add Name:=CN$ & "_ax", RefersTo:="=" & adr$ ' define neme for angle cell

' scroll bar for rotation around y
sel.Cells(1, 1).Offset(-9, -1).Value = "rotate y" ' caption
ActiveSheet.ScrollBars.Add(leftsel, topsel - 9 * 13, 260, 16).Select
adr$ = sel.Cells(1, 2).Offset(-4, 0).Address
    With Selection
        .Min = 0
        .Max = 360
        .Value = 180
        .SmallChange = 1
        .LargeChange = 10
        .LinkedCell = adr$
    End With
ActiveWorkbook.Names.Add Name:=CN$ & "_ay", RefersTo:="=" & adr$ ' define name for angle cell

回復 3# Guest from 128.100.71.x

' scroll bar for rotation around z
sel.Cells(1, 1).Offset(-8, -1).Value = "rotate z" ' caption
ActiveSheet.ScrollBars.Add(leftsel, topsel - 8 * 13, 260, 16).Select
adr$ = sel.Cells(1, 3).Offset(-4, 0).Address
    With Selection
        .Min = 0
        .Max = 360
        .Value = 70
        .SmallChange = 1
        .LargeChange = 10
        .LinkedCell = adr$
    End With
ActiveWorkbook.Names.Add Name:=CN$ & "_az", RefersTo:="=" & adr$ ' define name for angle cell
   
sel.Cells(1, 1).Offset(-3, -1).Value = "planes" ' caption
' scroll bar for cut plane x
sel.Cells(1, 1).Offset(-7, -1).Value = "cut plane YZ" ' caption
ActiveSheet.ScrollBars.Add(leftsel, topsel - 7 * 13, 250, 16).Select
adr$ = sel.Cells(1, 1).Offset(-3, 0).Address
    With Selection
        .Value = 0
        .Min = 0
        .Max = 100
        .SmallChange = 1
        .LargeChange = 5
        .LinkedCell = adr$
    End With
ActiveWorkbook.Names.Add Name:=CN$ & "_CP1", RefersTo:="=" & adr$ ' define name for cut plane value

sel.Cells(1, 1).Offset(-6, -1).Value = "cut plane XZ" ' caption
ActiveSheet.ScrollBars.Add(leftsel, topsel - 6 * 13, 250, 16).Select
adr$ = sel.Cells(1, 2).Offset(-3, 0).Address
    With Selection
        .Value = 0
        .Min = 0
        .Max = 100
        .SmallChange = 1
        .LargeChange = 5
        .LinkedCell = adr$
    End With
ActiveWorkbook.Names.Add Name:=CN$ & "_CP2", RefersTo:="=" & adr$ ' define name for cut plane value

sel.Cells(1, 1).Offset(-5, -1).Value = "cut plane XY" ' caption
ActiveSheet.ScrollBars.Add(leftsel, topsel - 5 * 13, 250, 16).Select
adr$ = sel.Cells(1, 3).Offset(-3, 0).Address
    With Selection
        .Value = 0
        .Min = 0
        .Max = 100
        .SmallChange = 1
        .LargeChange = 5
        .LinkedCell = adr$
    End With
ActiveWorkbook.Names.Add Name:=CN$ & "_CP3", RefersTo:="=" & adr$ ' define name for cut plane value

'Selection.Cells(1, 1).Offset(-2, 0).Address


' define raw data ranges
ActiveWorkbook.Names.Add Name:=CN$ & "_datx", RefersTo:="=" & sel.Columns(1 + dlb).Cells.Address
ActiveWorkbook.Names.Add Name:=CN$ & "_daty", RefersTo:="=" & sel.Columns(2 + dlb).Cells.Address
ActiveWorkbook.Names.Add Name:=CN$ & "_datz", RefersTo:="=" & sel.Columns(3 + dlb).Cells.Address

' The next definitions are used to bring the raw date into a normaised format, so that all values are within a range of zero to 1
' define minimal value
ActiveWorkbook.Names.Add Name:=CN$ & "_minx", RefersTo:="=MIN(" & CN$ & "_datx" & ")"
ActiveWorkbook.Names.Add Name:=CN$ & "_miny", RefersTo:="=MIN(" & CN$ & "_daty" & ")"
ActiveWorkbook.Names.Add Name:=CN$ & "_minz", RefersTo:="=MIN(" & CN$ & "_datz" & ")"
' define range
ActiveWorkbook.Names.Add Name:=CN$ & "_ranx", RefersTo:="=MAX(" & CN$ & "_datx" & ")-" & CN$ & "_minx"
ActiveWorkbook.Names.Add Name:=CN$ & "_rany", RefersTo:="=MAX(" & CN$ & "_daty" & ")-" & CN$ & "_miny"
ActiveWorkbook.Names.Add Name:=CN$ & "_ranz", RefersTo:="=MAX(" & CN$ & "_datz" & ")-" & CN$ & "_minz"
' define normalised data (-0.5 to +0.5) This range keeps the data points nicely centered on the origin in the XY plot
ActiveWorkbook.Names.Add Name:=CN$ & "_normx", RefersTo:="=(" & CN$ & "_datx-" & CN$ & "_minx)/" & CN$ & "_ranx -0.5"
ActiveWorkbook.Names.Add Name:=CN$ & "_normy", RefersTo:="=(" & CN$ & "_daty-" & CN$ & "_miny)/" & CN$ & "_rany -0.5"
ActiveWorkbook.Names.Add Name:=CN$ & "_normz", RefersTo:="=(" & CN$ & "_datz-" & CN$ & "_minz)/" & CN$ & "_ranz -0.5"

' define trigonometric values of angles
ActiveWorkbook.Names.Add Name:=CN$ & "_sx", RefersTo:="=SIN(RADIANS(" & CN$ & "_ax))"
ActiveWorkbook.Names.Add Name:=CN$ & "_sy", RefersTo:="=SIN(RADIANS(" & CN$ & "_ay))"
ActiveWorkbook.Names.Add Name:=CN$ & "_sz", RefersTo:="=SIN(RADIANS(" & CN$ & "_az))"
ActiveWorkbook.Names.Add Name:=CN$ & "_cx", RefersTo:="=COS(RADIANS(" & CN$ & "_ax))"
ActiveWorkbook.Names.Add Name:=CN$ & "_cy", RefersTo:="=COS(RADIANS(" & CN$ & "_ay))"
ActiveWorkbook.Names.Add Name:=CN$ & "_cz", RefersTo:="=COS(RADIANS(" & CN$ & "_az))"
' define rotation matrix values
ActiveWorkbook.Names.Add Name:=CN$ & "_rx1", RefersTo:="=" & CN$ & "_cy*" & CN$ & "_cz"
ActiveWorkbook.Names.Add Name:=CN$ & "_ry1", RefersTo:="=-" & CN$ & "_sz*" & CN$ & "_cy"
ActiveWorkbook.Names.Add Name:=CN$ & "_rz1", RefersTo:="=" & CN$ & "_sy"
ActiveWorkbook.Names.Add Name:=CN$ & "_rx2", RefersTo:="=" & CN$ & "_cz*" & CN$ & "_sy*" & CN$ & "_sx+" & CN$ & "_sz*" & CN$ & "_cx "
ActiveWorkbook.Names.Add Name:=CN$ & "_ry2", RefersTo:="=-" & CN$ & "_sz*" & CN$ & "_sy*" & CN$ & "_sx+" & CN$ & "_cz*" & CN$ & "_cx "
ActiveWorkbook.Names.Add Name:=CN$ & "_rz2", RefersTo:="=-" & CN$ & "_cy*" & CN$ & "_sx"

' calculate screen coordinates for data points
ActiveWorkbook.Names.Add Name:=CN$ & "_xs", RefersTo:="=" & CN$ & "_normx *" & CN$ & "_rx1+" & CN$ & "_normy *" & CN$ & "_ry1+" & CN$ & "_normz *" & CN$ & "_rz1"
ActiveWorkbook.Names.Add Name:=CN$ & "_ys", RefersTo:="=" & CN$ & "_normx *" & CN$ & "_rx2+" & CN$ & "_normy *" & CN$ & "_ry2+" & CN$ & "_normz *" & CN$ & "_rz2"

' insert new chart

ashn$ = ActiveSheet.Name
    Set co = ActiveSheet.ChartObjects.Add(leftsel + 350, topsel - 10 * 13, 500, 500)
    co.Select
    ActiveChart.ChartType = xlXYScatter
    ActiveChart.SetSourceData Source:=sel.Columns(2).Cells ' dummy assignment
    ActiveChart.Location Where:=xlLocationAsObject, Name:=ashn$
    ActiveChart.Legend.Delete
    ActiveChart.PlotArea.ClearFormats
   ActiveChart.Axes(xlValue).MajorGridlines.Delete
    With ActiveChart.Axes(xlValue)
        .MinimumScale = -0.95
        .MaximumScale = 0.95
    End With
        With ActiveChart.Axes(xlCategory)
        .MinimumScale = -0.95
        .MaximumScale = 0.95
    End With
    ActiveChart.Axes(xlValue).Delete
    ActiveChart.Axes(xlCategory).Delete

' ser$ = "=SERIES(" & Chr$(34) & CN$ & Chr$(34) & ",'" & ActiveWorkbook.Name & "'!" & CN$ & "_xs,'" & ActiveWorkbook.Name & "'!" & CN$ & "_ys,1)"
      
     ' ActiveChart.SeriesCollection(1).Formula = ser$
     'ActiveChart.SeriesCollection.NewSeries
    ActiveChart.SeriesCollection(1).Name = "=" & Chr$(34) & CN$ & Chr$(34)
    ActiveChart.SeriesCollection(1).XValues = "='" & ActiveWorkbook.Name & "'!" & CN$ & "_xs"
    ActiveChart.SeriesCollection(1).Values = "='" & ActiveWorkbook.Name & "'!" & CN$ & "_ys"

      
      
    With ActiveChart.SeriesCollection(1)
        .Border.Line = xlNone
        .MarkerBackgroundColor = RGB(0, 0, 200)
        .MarkerForegroundColor = RGB(0, 0, 212)
        .Marker = xlCircle
        .Smooth = False
        .MarkerSize = 7
        .Shadow = False
        If trcap = 1 Then .MarkerTransparency = 0.25
        '.Formula = ser$
    End With
   
    ' add data labels if required
    If dlb = 1 Then
        For p = 1 To ActiveChart.SeriesCollection(1).Points.Count
            ' dynamic label text
        lbt$ = "='" & ActiveSheet.Name & "'!" & sel.Cells(p, 1).Address(, , xlR1C1) ' sel.Cells(p, 1).Value
        
        With ActiveChart.SeriesCollection(1).Points(p)
            .HasDataLabel = True
            .DataLabel.Text = lbt$ ' "=" & sel.Cells(p, 1).Address
            .DataLabel.Font.Name = "Arial Narrow"
            .DataLabel.Font.Size = 10
            '.DataLabel.Font.Italic = True
        End With
        Next p
    End If
   


' define cartesian cage ("1st Octant")
    ActiveWorkbook.Names.Add Name:="cagex", RefersTo:="={0.5,-0.5,-0.5,0.5,0.5,0.5,-0.5,-0.5,-0.5,-0.5,-0.5}"
    ActiveWorkbook.Names.Add Name:="cagey", RefersTo:="={-0.5,-0.5,-0.5,-0.5,-0.5,0.5,0.5,0.5,-0.5,-0.5,0.5}"
    ActiveWorkbook.Names.Add Name:="cagez", RefersTo:="={-0.5,-0.5,0.5,0.5,-0.5,-0.5,-0.5,0.5,0.5,-0.5,-0.5}"
'={1\0\0\1\1\1\0\0\0\0\0} 'names dialog box will display backward-slashes \ as delimiter, but only commas, work in VBA code. Weird that
'={0\0\0\0\0\1\1\1\0\0\1}
'={0\0\1\1\0\0\0\1\1\0\0}

' calculate screen coordinates for cartesian cage
ActiveWorkbook.Names.Add Name:=CN$ & "_xs_cage", RefersTo:="=" & "cagex *" & CN$ & "_rx1+" & "cagey *" & CN$ & "_ry1+" & "cagez *" & CN$ & "_rz1"
ActiveWorkbook.Names.Add Name:=CN$ & "_ys_cage", RefersTo:="=" & "cagex *" & CN$ & "_rx2+" & "cagey *" & CN$ & "_ry2+" & "cagez *" & CN$ & "_rz2"

      
ActiveChart.SeriesCollection.NewSeries
ns = ActiveChart.SeriesCollection.Count
ActiveChart.SeriesCollection(ns).Name = "=" & Chr$(34) & "cage" & Chr$(34)
ActiveChart.SeriesCollection(ns).XValues = "='" & ActiveWorkbook.Name & "'!" & CN$ & "_xs_cage"
ActiveChart.SeriesCollection(ns).Values = "='" & ActiveWorkbook.Name & "'!" & CN$ & "_ys_cage"
   
With ActiveChart.SeriesCollection(ns)
        .Border.Color = RGB(150, 150, 150)
        .Border.LineWeight = 0
        .Border.Line = xlContinuous
        If trcap = 1 Then .Border.Transparency = 0.5
        .Marker = xlNone
        .Smooth = False
        .Shadow = False
End With

ns = ActiveChart.SeriesCollection.Count

' add data labels to cage to mark positive x axis direction
If sel.Cells(1, 1 + dlb).Offset(-1, 0).Value = "" Then sel.Cells(1, 1 + dlb).Offset(-1, 0).Value = "X axis"
lbt$ = "='" & ActiveSheet.Name & "'!" & sel.Cells(1, 1 + dlb).Offset(-1, 0).Address(, , xlR1C1)
    With ActiveChart.SeriesCollection(ns).Points(1)
            .HasDataLabel = True
            .DataLabel.Text = lbt$
            .DataLabel.Font.Name = "Arial Narrow"
            .DataLabel.Font.Size = 12
            .DataLabel.Position = xlLabelPositionLeft
            '.DataLabel.Font.Italic = True
        End With
' add data labels to cage to mark positive y axis direction
If sel.Cells(1, 2 + dlb).Offset(-1, 0).Value = "" Then sel.Cells(1, 2 + dlb).Offset(-1, 0).Value = "Y axis"
lbt$ = "='" & ActiveSheet.Name & "'!" & sel.Cells(1, 2 + dlb).Offset(-1, 0).Address(, , xlR1C1)
    With ActiveChart.SeriesCollection(ns).Points(11)
            .HasDataLabel = True
            .DataLabel.Text = lbt$
            .DataLabel.Font.Name = "Arial Narrow"
            .DataLabel.Font.Size = 12
            .DataLabel.Position = xlLabelPositionRight
            '.DataLabel.Font.Italic = True
        End With
' add data labels to cage to mark positive z axis direction
If sel.Cells(1, 3 + dlb).Offset(-1, 0).Value = "" Then sel.Cells(1, 3 + dlb).Offset(-1, 0).Value = "Z axis"
lbt$ = "='" & ActiveSheet.Name & "'!" & sel.Cells(1, 3 + dlb).Offset(-1, 0).Address(, , xlR1C1)
    With ActiveChart.SeriesCollection(ns).Points(9)
            .HasDataLabel = True
            .DataLabel.Text = lbt$
            .DataLabel.Font.Name = "Arial Narrow"
            .DataLabel.Font.Size = 12
            .DataLabel.Position = xlLabelPositionAbove
           '.DataLabel.Font.Italic = True
        End With


' define position of cut planes (from slider positions)
    ActiveWorkbook.Names.Add Name:=CN$ & "_cpx", RefersTo:="=" & CN$ & "_CP1/100 - 0.5"
    ActiveWorkbook.Names.Add Name:=CN$ & "_cpy", RefersTo:="=" & CN$ & "_CP2/100 - 0.5"
    ActiveWorkbook.Names.Add Name:=CN$ & "_cpz", RefersTo:="=" & CN$ & "_CP3/100 - 0.5"
   
' default geometry for cut plane outlines
ActiveWorkbook.Names.Add Name:="plane1", RefersTo:="={-0.5,0.5,0.5,-0.5,-0.5}"
ActiveWorkbook.Names.Add Name:="plane2", RefersTo:="={-0.5,-0.5,0.5,0.5,-0.5}"
'plane1  ={0\1\1\0\0}
'plane2  ={0\0\1\1\0}
   
' calculate screen coordinates for datapoints of three cut planes
ActiveWorkbook.Names.Add Name:=CN$ & "_xs_cpx", RefersTo:="=" & CN$ & "_cpx *" & CN$ & "_rx1+" & CN$ & "_normy *" & CN$ & "_ry1+" & CN$ & "_normz *" & CN$ & "_rz1"
ActiveWorkbook.Names.Add Name:=CN$ & "_ys_cpx", RefersTo:="=" & CN$ & "_cpx *" & CN$ & "_rx2+" & CN$ & "_normy *" & CN$ & "_ry2+" & CN$ & "_normz *" & CN$ & "_rz2"

ActiveWorkbook.Names.Add Name:=CN$ & "_xs_cpy", RefersTo:="=" & CN$ & "_normx *" & CN$ & "_rx1+" & CN$ & "_cpy *" & CN$ & "_ry1+" & CN$ & "_normz *" & CN$ & "_rz1"
ActiveWorkbook.Names.Add Name:=CN$ & "_ys_cpy", RefersTo:="=" & CN$ & "_normx *" & CN$ & "_rx2+" & CN$ & "_cpy *" & CN$ & "_ry2+" & CN$ & "_normz *" & CN$ & "_rz2"

ActiveWorkbook.Names.Add Name:=CN$ & "_xs_cpz", RefersTo:="=" & CN$ & "_normx *" & CN$ & "_rx1+" & CN$ & "_normy *" & CN$ & "_ry1+" & CN$ & "_cpz *" & CN$ & "_rz1"
ActiveWorkbook.Names.Add Name:=CN$ & "_ys_cpz", RefersTo:="=" & CN$ & "_normx *" & CN$ & "_rx2+" & CN$ & "_normy *" & CN$ & "_ry2+" & CN$ & "_cpz *" & CN$ & "_rz2"

' calculate screen coordinates for outlines of three cut planes
ActiveWorkbook.Names.Add Name:=CN$ & "_xs_planex", RefersTo:="=" & CN$ & "_cpx *" & CN$ & "_rx1+" & "plane1 *" & CN$ & "_ry1+" & "plane2 *" & CN$ & "_rz1"
ActiveWorkbook.Names.Add Name:=CN$ & "_ys_planex", RefersTo:="=" & CN$ & "_cpx *" & CN$ & "_rx2+" & "plane1 *" & CN$ & "_ry2+" & "plane2 *" & CN$ & "_rz2"

ActiveWorkbook.Names.Add Name:=CN$ & "_xs_planey", RefersTo:="=" & "plane1 *" & CN$ & "_rx1+" & CN$ & "_cpy *" & CN$ & "_ry1+" & "plane2 *" & CN$ & "_rz1"
ActiveWorkbook.Names.Add Name:=CN$ & "_ys_planey", RefersTo:="=" & "plane1 *" & CN$ & "_rx2+" & CN$ & "_cpy *" & CN$ & "_ry2+" & "plane2 *" & CN$ & "_rz2"

ActiveWorkbook.Names.Add Name:=CN$ & "_xs_planez", RefersTo:="=" & "plane1 *" & CN$ & "_rx1+" & "plane2 *" & CN$ & "_ry1+" & CN$ & "_cpz *" & CN$ & "_rz1"
ActiveWorkbook.Names.Add Name:=CN$ & "_ys_planez", RefersTo:="=" & "plane1 *" & CN$ & "_rx2+" & "plane2 *" & CN$ & "_ry2+" & CN$ & "_cpz *" & CN$ & "_rz2"

' add datapoints for x cut plane (along YZ)
ActiveChart.SeriesCollection.NewSeries
ns = ActiveChart.SeriesCollection.Count
ActiveChart.SeriesCollection(ns).Name = "=" & Chr$(34) & CN$ & "_cut_plane_YZ_points" & Chr$(34)
ActiveChart.SeriesCollection(ns).XValues = "='" & ActiveWorkbook.Name & "'!" & CN$ & "_xs_cpx"
ActiveChart.SeriesCollection(ns).Values = "='" & ActiveWorkbook.Name & "'!" & CN$ & "_ys_cpx"
  With ActiveChart.SeriesCollection(ns)
        .Border.Line = xlNone
        .MarkerBackgroundColor = RGB(200, 40, 0)
        .MarkerForegroundColor = RGB(200, 40, 0)
        .Marker = xlCircle
        .Smooth = False
        .MarkerSize = 3
        .Shadow = False
        If trcap = 1 Then .MarkerTransparency = 0.5
    End With
' add outline for x cut plane (along YZ)
ActiveChart.SeriesCollection.NewSeries
ns = ActiveChart.SeriesCollection.Count
ActiveChart.SeriesCollection(ns).Name = "=" & Chr$(34) & CN$ & "_cut_plane_YZ_outline" & Chr$(34)
ActiveChart.SeriesCollection(ns).XValues = "='" & ActiveWorkbook.Name & "'!" & CN$ & "_xs_planex"
ActiveChart.SeriesCollection(ns).Values = "='" & ActiveWorkbook.Name & "'!" & CN$ & "_ys_planex"
With ActiveChart.SeriesCollection(ns)
        .Border.Color = RGB(200, 40, 0)
        .Border.LineWeight = 0
        .Border.Line = xlContinuous
        If trcap = 1 Then .Border.Transparency = 0.5
        .Marker = xlNone
        .Smooth = False
        .Shadow = False
End With

' add datapoints for y cut plane (along XZ)
ActiveChart.SeriesCollection.NewSeries
ns = ActiveChart.SeriesCollection.Count
ActiveChart.SeriesCollection(ns).Name = "=" & Chr$(34) & CN$ & "_cut_plane_XZ_points" & Chr$(34)
ActiveChart.SeriesCollection(ns).XValues = "='" & ActiveWorkbook.Name & "'!" & CN$ & "_xs_cpy"
ActiveChart.SeriesCollection(ns).Values = "='" & ActiveWorkbook.Name & "'!" & CN$ & "_ys_cpy"
  With ActiveChart.SeriesCollection(ns)
        .Border.Line = xlNone
        .MarkerBackgroundColor = RGB(0, 200, 0)
        .MarkerForegroundColor = RGB(0, 200, 0)
        .Marker = xlCircle
        .Smooth = False
        .MarkerSize = 3
        .Shadow = False
        If trcap = 1 Then .MarkerTransparency = 0.5
    End With
' add outline for y cut plane (along XZ)
ActiveChart.SeriesCollection.NewSeries
ns = ActiveChart.SeriesCollection.Count
ActiveChart.SeriesCollection(ns).Name = "=" & Chr$(34) & CN$ & "_cut_plane_XZ_outline" & Chr$(34)
ActiveChart.SeriesCollection(ns).XValues = "='" & ActiveWorkbook.Name & "'!" & CN$ & "_xs_planey"
ActiveChart.SeriesCollection(ns).Values = "='" & ActiveWorkbook.Name & "'!" & CN$ & "_ys_planey"
With ActiveChart.SeriesCollection(ns)
        .Border.Color = RGB(0, 200, 0)
        .Border.LineWeight = 0
        .Border.Line = xlContinuous
        If trcap = 1 Then .Border.Transparency = 0.5
        .Marker = xlNone
        .Smooth = False
        .Shadow = False
End With

' add datapoints for z cut plane (along XY)
ActiveChart.SeriesCollection.NewSeries
ns = ActiveChart.SeriesCollection.Count
ActiveChart.SeriesCollection(ns).Name = "=" & Chr$(34) & CN$ & "_cut_plane_XY_points" & Chr$(34)
ActiveChart.SeriesCollection(ns).XValues = "='" & ActiveWorkbook.Name & "'!" & CN$ & "_xs_cpz"
ActiveChart.SeriesCollection(ns).Values = "='" & ActiveWorkbook.Name & "'!" & CN$ & "_ys_cpz"
  With ActiveChart.SeriesCollection(ns)
        .Border.Line = xlNone
        .MarkerBackgroundColor = RGB(0, 0, 250)
        .MarkerForegroundColor = RGB(0, 0, 250)
        .Marker = xlCircle
        .Smooth = False
        .MarkerSize = 3
        .Shadow = False
        If trcap = 1 Then .MarkerTransparency = 0.5
    End With
' add outline for y cut plane (along XY)
ActiveChart.SeriesCollection.NewSeries
ns = ActiveChart.SeriesCollection.Count
ActiveChart.SeriesCollection(ns).Name = "=" & Chr$(34) & CN$ & "_cut_plane_XY_outline" & Chr$(34)
ActiveChart.SeriesCollection(ns).XValues = "='" & ActiveWorkbook.Name & "'!" & CN$ & "_xs_planez"
ActiveChart.SeriesCollection(ns).Values = "='" & ActiveWorkbook.Name & "'!" & CN$ & "_ys_planez"
With ActiveChart.SeriesCollection(ns)
        .Border.Color = RGB(0, 0, 250)
        .Border.LineWeight = 0
        .Border.Line = xlContinuous
        If trcap = 1 Then .Border.Transparency = 0.5
        .Marker = xlNone
        .Smooth = False
        .Shadow = False
End With

' bring data points series to the front
ActiveChart.SeriesCollection(1).PlotOrder = ns ' ns contains the current number of series in the chart


End Sub


Sub DeleteAllNames()

For i = 1 To ActiveWorkbook.Names.Count - 1
ActiveWorkbook.Names.Item(1).Delete 'last remaining item will not be i, but 1
Next i

End Sub


Sub ColorPointsFromZ()

' assumes chart series is selected

dg = 3 ' number of significant digits in color legend

Application.ScreenUpdating = False

Set ser = Selection
serfo = ser.Formula

p = Application.WorksheetFunction.Search("!", serfo, 1) ' look for delimiter to ranged name ( SERIES("series name",'Workbookname.xls'!XXXXXXX_xs,...)
u = Application.WorksheetFunction.Search("_", serfo, p + 1) ' look for first underscore in to ranged name ( SERIES("series name",'Workbookname.xls'!XXXXXXX_xs,...)

sernm = Mid(serfo, p + 1, u - p - 1) ' locate given identificator (series name) in defined names

Set datz = Range(sernm & "_datz") ' original data values

mtr = 0 ' marker transparency
msz = 10 ' marker size

'determine if color transparency can be set
trcap = 1 ' flag for transparent color capability
With ActiveSheet.Shapes.AddShape(msoShapeOval, 2, 2, 20, 20)
    On Error GoTo notrsp
    .Fill.Transparency = 0.5
    On Error GoTo 0
    .Delete
End With
GoTo trsp:
notrsp: trcap = 0
trsp:


' determine if series is for a cut plane
On Error GoTo fore
If Application.WorksheetFunction.Search("cut_plane", serfo, 1) <> 0 Then
    cupl = 1 ' flag for cut plane
    mtr = 0.6 ' marker transparency
    msz = 3 ' marker size
End If
On Error GoTo 0

fore:

' determine minima and maxima in z values
minz = Application.WorksheetFunction.Min(Range(sernm & "_datz"))
maxz = Application.WorksheetFunction.Max(Range(sernm & "_datz"))

ranz = maxz - minz ' range of z values

' MsgBox minz & vbTab & maxz & vbTab & ranz

' make all point the same
ser.Marker = xlAutomatic
'ser.MarkerBackgroundColor = RGB(0, 0, 250)
'ser.MarkerForegroundColor = RGB(0, 0, 250)

' info for redefining the default color palette info
fre = -0.51 ' frequency of change for red
pre = 255 ' phase for red
fgr = -1.36 ' frequency of change for green
pgr = 200 ' phase for green
fbl = -0.816 ' frequency of change for blue
pbl = 102 ' phase for blue



For i = 1 To Range(sernm & "_datz").Rows.Count
    ' normalised z values (0 to 1)
    NCV = (datz.Cells(i, 1).Value - minz) / ranz ' - 0.5
    ncol = Int(NCV * 50 + 6)
   
    re = (ncol * 10 * fre + pre) / 510: re = Abs((re - Int(re)) * 510 - 255)
    gr = (ncol * 10 * fgr + pgr) / 510: gr = Abs((gr - Int(gr)) * 510 - 255)
    bl = (ncol * 10 * fbl + pbl) / 510: bl = Abs((bl - Int(bl)) * 510 - 255)
  
   
    'ser.Points(i).Select
    'Selection.MarkerForegroundColor = RGB(re, gr, bl) ' MarkerForegroundColor = ncol  'assign colors from 6 to 56 to datapoint
    With ser.Points(i)
        '.MarkerBackgroundColor = RGB(re, gr, bl)
        '.MarkerForegroundColor = RGB(re, gr, bl)
        .MarkerBackgroundColorIndex = ncol
        .MarkerForegroundColorIndex = ncol
        If trcap = 1 Then .MarkerTransparency = mtr  '  dependent on type of series: main or cut plane?
        .Shadow = False
        .Marker = xlCircle
        .MarkerSize = msz ' dependent on type of series: main or cut plane?
    End With
   
   
   
    datz.Cells(i, 1).Interior.ColorIndex = ncol
    ' datz.Cells(i, 1).Interior.Color = RGB(re, gr, bl)

   
Next i

If cupl = 1 Then GoTo skiplegend ' do not draw color legends if cut planes are colored

' create color legend

' find position for legend (to the right of the chart)
xl = ActiveChart.Parent.Left + ActiveChart.Parent.Width + 15 ' the obvious ActiveChart.ChartArea.Left will not work, but gives the distance between ChartArea (outer border of chart) and PlotArea, i.e. 4)
yl = ActiveChart.Parent.Top
nbw = Application.WorksheetFunction.Max(Len(Int(minz)), Len(Int(maxz))) * 5 ' approximate space needed for decimal places

datz.Cells(1, 1).Select ' deselect chart shape

shar$ = "" ' string with shape names array

For i = 6 To 56 Step 2
    ' find z value to this color
    zval = (i + 0.5 - 6) / 50 * ranz + minz
   
    ' round to dg digits
     If zval <> 0 Then
     lzv = Log(Abs(zval)) / Log(10) ' LOG in VBA is natural logarithm, not base 10 logarithm
     zval = Application.WorksheetFunction.Round(zval, (dg - Int(lzv + 1))) ' rounding defect ##### returns 0
    End If


    With ActiveSheet.Shapes.AddShape(msoShapeOval, xl, yl + (i - 6) * 6.5, 10, 10)
            .Fill.ForeColor.SchemeColor = i + 7 ' for some reason IndexColor 6 is SchemeColor 13, i.e. +7 (There are 82 SchemeColors, but only 56 IndexColors....)
            .Select (False) ' extend selection to include this shape
    End With
   
    ' to find position of decimal point: create dummy label with abs value
    azval = Int(Abs(zval))
    If Sgn(zval) = -1 Then azval = "-" & azval
    With ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, xl + 15, yl - 1 + (i - 6) * 6.5, 99, 12)
        .TextFrame.Characters.Text = azval
        .TextFrame.Characters.Font.Name = "Arial Narrow"
        .TextFrame.Characters.Font.Size = 10
        .Fill.Visible = msoFalse
        .Line.Visible = msoFalse
        .TextFrame.AutoSize = True
        wdll = .Width ' remember width of legend label
       .Delete
    End With

   
     With ActiveSheet.Shapes.AddTextbox(msoTextOrientationHorizontal, xl + 20 + nbw - wdll, yl - 1 + (i - 6) * 6.5, 99, 12)
        .TextFrame.Characters.Text = zval
        .TextFrame.Characters.Font.Name = "Arial Narrow"
        .TextFrame.Characters.Font.Size = 10
        .Fill.Visible = msoFalse
        .Line.Visible = msoFalse
        .TextFrame.AutoSize = True
        .Select (False) ' extend selection to include this shape
    End With

Next i


With Selection.ShapeRange.Group ' make legend shapes into one group
    .IncrementLeft (Rnd() * 10) ' move a bit so multiple legends are not covering each other up
    .IncrementTop (Rnd() * 10)
End With

skiplegend:

End Sub


Sub MakeNiceGradientColorPalette()

' info for redefining the default color palette info
' ocean - blues - cyan - bluegray - mauve - red - orange - yellow ########
fre = -0.51 ' frequency of change for red
pre = 255 ' phase for red
fgr = -1.36 ' frequency of change for green
pgr = 200 ' phase for green
fbl = -0.816 ' frequency of change for blue
pbl = 102 ' phase for blue

Application.ScreenUpdating = False

shnm = ActiveSheet.Name

ActiveWorkbook.Sheets.Add

ActiveSheet.Name = "color palette " & Application.WorksheetFunction.Substitute(Str(Time()), ":", "_")
Range("B2").Select
Selection.Cells(1, 1).Value = "New Color Palette with red/green/blue values (This is NOT interactive and can be deleted)"
Selection.Cells(1, 1).Offset(1, 0).Select


' redefine default color palette colors 6 to 56
n = 0
For i = 6 To 56

    re = (n * fre + pre) / 510: re = Abs((re - Int(re)) * 510 - 255)
    gr = (n * fgr + pgr) / 510: gr = Abs((gr - Int(gr)) * 510 - 255)
    bl = (n * fbl + pbl) / 510: bl = Abs((bl - Int(bl)) * 510 - 255)
    n = n + 10
    ActiveWorkbook.Colors(i) = RGB(re, gr, bl)
    Selection.Cells(1, 1).Interior.ColorIndex = i
    Selection.Cells(1, 1).Value = Int(re) & " / " & Int(gr) & " / " & Int(bl)
    Selection.Cells(1, 1).Offset(1, 0).Select
   
Next i

Sheets(shnm).Activate

' what follows is a repository for useful palette parameters (for being copied into code above)

' violet - brown  - light pink - light green - green - blue
fre = 1 ' frequency of change for red
pre = 170 ' phase for red
fgr = 1 ' frequency of change for green
pgr = 255 ' phase for green
fbl = 1.7 ' frequency of change for blue
pbl = 0 ' phase for blue

' blue - green - brown - red - light red
fre = 0.51 ' frequency of change for red
pre = 255 ' phase for red
fgr = 1.36 ' frequency of change for green
pgr = 255 ' phase for green
fbl = 0.816 ' frequency of change for blue
pbl = 0 ' phase for blue

' blue- violet - brown yellow - light green
fre = 0.612 ' frequency of change for red
pre = 319 ' phase for red
fgr = 0.51 ' frequency of change for green
pgr = 255 ' 382 ' phase for green
fbl = 0.765 ' frequency of change for blue
pbl = 0 ' phase for blue

' blue -violet - orange - green #####
fre = 0.612 ' frequency of change for red
pre = 319 ' phase for red
fgr = 0.51 ' frequency of change for green
pgr = 255 ' 382 ' phase for green
fbl = 0.765 ' frequency of change for blue
pbl = 0 ' phase for blue

' yellow - orange - mauve - violet - light blue - cyan - dark blue-green #####
fre = 0.51 ' frequency of change for red
pre = 0 ' phase for red
fgr = 1.36 ' frequency of change for green
pgr = 0 ' phase for green
fbl = 0.816 ' frequency of change for blue
pbl = 255 ' phase for blue

' cyan - mid blue - violet - brown - citron - dark orange
fre = -0.51 ' frequency of change for red
pre = 255 ' phase for red
fgr = -1.36 ' frequency of change for green
pgr = 22 ' phase for green
fbl = -0.816 ' frequency of change for blue
pbl = 102 ' phase for blue

' ocean - blues - cyan - bluegray - mauve - red - orange - yellow ########
fre = -0.51 ' frequency of change for red
pre = 255 ' phase for red
fgr = -1.36 ' frequency of change for green
pgr = 200 ' phase for green
fbl = -0.816 ' frequency of change for blue
pbl = 102 ' phase for blue

' black - plum - pink - lavender - blegreen - cyangreen
fre = 0.11 ' frequency of change for red
pre = 248 ' phase for red
fgr = 0.4 ' frequency of change for green
pgr = 255 ' phase for green
fbl = 0.8 ' frequency of change for blue
pbl = 255 ' phase for blue

' green - plum - violet - magenta - orange - dark yellow
fre = 0.5 ' frequency of change for red
pre = 305 ' phase for red
fgr = 0.7 ' frequency of change for green
pgr = 64 ' phase for green
fbl = 1.1 ' frequency of change for blue
pbl = 267 ' phase for blue

' greenish grey - light blue - light green - light brown - orange - dark orange
fre = 0.5 ' frequency of change for red
pre = 291 ' phase for red
fgr = 0.75 ' frequency of change for green
pgr = 298 ' phase for green
fbl = 1.1 ' frequency of change for blue
pbl = 267 ' phase for blue

' bicolor: green -(dark middle) - violet
fre = 0.5 ' frequency of change for red
pre = 153 ' phase for red
fgr = 0.5 ' frequency of change for green
pgr = 80 ' phase for green
fbl = 0.5 ' frequency of change for blue
pbl = 145 ' phase for blue

' blue - violet - red
fre = 0.5 ' frequency of change for red
pre = 275 ' phase for red
fgr = 0 ' frequency of change for green
pgr = 255 ' phase for green
fbl = 0.5 ' frequency of change for blue
pbl = 25 ' phase for blue

' green - bluegreen - violet - purple - orange
fre = 0.5 ' frequency of change for red
pre = 240 ' phase for red
fgr = 0.7 ' frequency of change for green
pgr = 510 ' phase for green
fbl = 1.05 ' frequency of change for blue
pbl = 240 ' phase for blue

End Sub



Sub ListColorIndex()

For i = 0 To 56

    Selection.Cells(1, 1).Interior.ColorIndex = i
    Selection.Cells(1, 1).Offset(1, 0).Select
Next i

End Sub

Sub ListIndexColorsAndSchemeColorsWithShapes()

For i = 0 To 81

    If i <= 56 Then Selection.Cells(1, 1).Interior.ColorIndex = i
    Selection.Cells(1, 1).Value = i
    With ActiveSheet.Shapes.AddShape(msoShapeOval, Selection.Cells(1, 1).Left + Selection.Cells(1, 1).Width + 5, Selection.Cells(1, 1).Top, 10, 10)
            .Fill.ForeColor.SchemeColor = i
    End With
    Selection.Cells(1, 1).Offset(1, 0).Select

Next i
end sub