vba写一个南丁格尔玫瑰图

由于南丁格尔玫瑰图需要用到极坐标系，因此需要采用自定义图表类型来绘制。以下是一个简单的 VBA 代码示例，可以用于绘制南丁格尔玫瑰图：

```

Sub DrawNightingale()

    Dim rngData As Range

    Set rngData = Range("B2:B13")  ' 数据范围

    ' 创建自定义图表类型

    Dim cht As Chart

    Set cht = Charts.Add

    With cht.ChartArea

        .Clear

        .Format.Fill.Visible = msoFalse  ' 背景填充透明

        .Format.Line.Visible = msoFalse  ' 边框线不可见

    End With

    cht.ChartType = xlCustom

    cht.ChartStyle = 241

    ' 添加系列数据

    Dim srs As Series

    Set srs = cht.SeriesCollection.NewSeries

    srs.Values = rngData

    srs.ChartType = xlColumnClustered

    srs.ChartType = xlXYScatterLines  ' 设置为拆线图

    srs.HasLeaderLines = True

    srs.LeaderLines.Border.ColorIndex = 1  ' 设置引导线颜色

    srs.LeaderLines.Border.Weight = xlThin  ' 设置引导线宽度

    ' 设置系列点位置

    Dim minVal As Double, maxVal As Double

    minVal = WorksheetFunction.Min(rngData)

    maxVal = WorksheetFunction.Max(rngData)

    For i = 1 To rngData.Cells.Count

        Dim r As Double, theta As Double

        Dim val As Double

        val = rngData.Cells(i).Value

        r = (val - minVal) / (maxVal - minVal)  ' 极径

        theta = (i - 1) / rngData.Cells.Count * 2 * WorksheetFunction.Pi  ' 极角

        srs.Points(i).Format.Line.Visible = msoFalse  ' 点边框不可见

        srs.Points(i).MarkerStyle = xlMarkerStyleCircle  ' 设置点标记

        srs.Points(i).MarkerSize = 10  ' 设置点大小

        srs.Points(i).MarkerForegroundColor = cht.SeriesCollection(1).Points(i).Format.Fill.ForeColor  ' 按照系列颜色设置点颜色

        srs.Points(i).MarkerBackgroundColor = msoColorAutomatic

        srs.Points(i).Format.Fill.Visible = msoTrue  ' 点填充可见

        srs.Points(i).Left = r * Cos(theta)

        srs.Points(i).Top = r * Sin(theta)

    Next i

    ' 添加坐标轴标签

    Dim ax As Axis

    Set ax = cht.Axes(xlValue, xlPrimary)

    ax.Delete

    Set ax = cht.Axes(xlCategory, xlPrimary)

    ax.CategoryNames = Range("A2:A13")

    ax.MajorTickMark = xlTickMarkNone

    ax.MinorTickMark = xlTickMarkNone

    ax.Crosses = xlCustom

    ax.CrossesAt = -0.5

    ax.AxisBetweenCategories = True

    ax.TickLabelSpacing = 1

    ax.TickLabels.Orientation = xlUpward

    ax.TickLabels.Font.Size = 10

    ' 添加图例

    Dim lgd As Legend

    Set lgd = cht.Legend

    lgd.Delete

    ' 调整图表大小和位置

    cht.Parent.Width = 300

    cht.Parent.Height = 300

    cht.Parent.Left = 200

    cht.Parent.Top = 200

End Sub

```

该代码可以将 Excel 中 B2:B13 范围内的数据绘制成南丁格尔玫瑰图。请注意，该代码仅适用于 Excel 2010 及以上版本。如果您使用的是较早的 Excel 版本，可能需要进行一些调整。同时，请确保在代码执行之前选中正确的工作表和数据范围。