博文
双Y绘图的VBA代码
|
这个是我的得意之作，代码大体修缮完毕。里面关于美化的细节问题，如有需要可自行修改相关参数。示例excel双Y绘图样表.xlsx与代码双Y绘图.txt，请自行下载
代码如下：
Option Explicit
Public N1
Public Colum_of_pic
Sub aya_graphics()
'----------------------功能---------------------------'
'将多组数据绘制在一幅图中（更改k值）
'将多组数据绘制在多幅图中（更改k值及n值）
'将多个sheet中的多组数据绘制在多幅图中（更改k值，n值以及l值）
'-----------------------------------------------------'
'--------------------基本思路------------------------'
'明确一个sheet里需要绘制几幅图，每幅图里有几个数据序列，以及有多少个sheet
'一幅图表基本要素有：图表（绘图区，坐标轴，坐标轴标题，图名，图例等）
'绘图的基本流程
'1.创建一个空图表（设置图表类型、宽高及位置）
'2.在空图表中创建绘图区（设置宽高及位置）
'3.在绘图区添加数据系列（指定X轴数据列与Y轴数据列），修改数据系列的颜色、设置数据标记、线宽（基本设置，其余设置可后续扩展）
'4.添加图表标题，设置内容、字体、字号、位置等
'5.删除原有图例，添加新图例，设置字体、字号、位置、宽高等
'6.修改X坐标轴的参数，Y坐标轴参数以及次Y坐标轴参数（如果有的话）
'7.绘制多幅图的要点在于循环数的使用，要将数据系列的指定参数与循环数相结合，保证每次循环都可以选中正确的数据系列
'8.关于程序调试，可在vba中使用逐行运行来观察每一行代码所实现的功能，结合注释理解含义
'9.本程序虽然可以通过循环数绘制多幅图，但归根结底绘图对象只有一个，即ch（见定义区）。若要在同一个循环内绘制两幅图像，则需要再定义一个 ChartObject，并进行相应设置，即ch2
'-----------------------------------------------------'
'--------------------注意事项------------------------'
'为了简化代码编写，相关参数可能过于机械，所以需要先行将数据格式处理成所需样式
'基本格式为一幅图中的数据排在一起，多幅图中的数据集间隔相等，各个sheet的数据集位置一致
'由于次Y坐标轴的参数不常用，因此在代码中直接修改相关参数即可
'-----------------------------------------------------'
'-----------------定义区（无需修改）-------------------'
Dim i As Integer '循环数i定义为整型
Dim j As Integer '循环数j定义为整型
Dim l As Integer '循环数k定义为整型
Dim n As Integer '绘图数n定义为整型
Dim k As Integer '数据系列数k定义为整型
Dim m As Integer 'sheet数m定义为整型
Dim r_start As Integer '数据起始行定义为整型
Dim r_end As Integer '数据终止行定义为整型
Dim c_start As Integer '数据起始列定义为整型
Dim dataSet_space As Integer '数据集间隔定义为整型
Dim Name() As Variant '数据系列名称Name()定义为空数组
Dim Title() As Variant '图表名称Title()定义为空数组
Dim SheetName() As Variant 'sheet名称SheetName()定义为空数组
Dim ch As ChartObject 'ch定义为绘图对象
'Dim ch2 As ChartObject
'-----------------------------------------------------'
'------------------数据源设置（需修改）-----------------'
k = 2 '数据系列数
n = 3 '绘图数
m = 2 'sheet数
r_start = 3 '数据起始行
r_end = 20 '数据终止行
c_start = 1 '数据起始列
dataSet_space = 6 '数据集间隔
Name = Array("c1", "c2", "断面地形") '填充数组（可按上述格式添加新数据）
Title = Array("X1断面", "X2断面", "X3断面") '填充数组（可按上述格式添加新数据）
SheetName = Array("CS1", "CS2", "CS3") '填充数组（可按上述格式添加新数据）
'-----------------------------------------------------'
'-------------------图表格式（需修改）------------------'
'声明常量 坐标轴刻度设置
Const Xmin As Variant = 0, Xmax As Variant = 2000, Xunit As Variant = 200, Xcross As Variant = 0 'X最大值、最小值、主间距、交叉点
Const ymin As Variant = -1, ymax As Byte = 1, yunit As Variant = 0.5, ycross As Variant = 0 'Y最大值、最小值、主间距、交叉点
Const Ysmin As Variant = 0, Ysmax As Byte = 50, Ysunit As Variant = 5, Yscross As Variant = 0 'Ys最大值、最小值、主间距、交叉点（双Y坐标轴中的次坐标）
'声明常量 图表尺寸
Const W1 As Variant = 12, H1 As Variant = 6.5 '定义图表区 宽度W1、高度H1(cm)
Const L2 As Variant = 0.5, T2 As Variant = 2, W2 As Variant = 11, H2 As Variant = 6 '定义绘图区 左距L2、上距T2、宽度W2、高度H2(cm)
Const L3 As Variant = 2.5, T3 As Variant = 0.6, W3 As Variant = 6, H3 As Variant = 0.5 '定义图例 左距L3、上距T3、宽度W3、高度H3(cm) '
Const L4 As Variant = 5.7 '定义标题 左距L4(cm)
'声明常量 图表字体
Const TitleSize As Byte = 10 '标题字号
Const AxesSize As Byte = 8 '坐标轴字号
Const AxesNameSize As Byte = 9 '坐标轴标题字号
Const LegendSize As Byte = 7 '图例字号
Const MarkerSize As Byte = 2 '标记大小
Const LineWeight As Single = 0.75 '线宽
'声明常量 坐标轴标题
Const AxeXTitle As String = "起点距(m)" 'X轴标题
Const AxeYTitle As String = "流速(m/s)" 'Y轴标题
Const AxeYTitle1 As String = "高程(m)" '次Y轴标题
Const AxeFont As String = "Times New Roman" '字体
'--------------------------------------------------------'
'图表尺寸转换(cm转为磅)(自动计算无需修改)
Const W11 As Variant = W1 * 28.08, H11 As Variant = H1 * 28.08
Const L21 As Variant = L2 * 28.08, T21 As Variant = T2 * 28.08, W21 As Variant = W2 * 28.08, H21 As Variant = H2 * 28.08
Const L31 As Variant = L3 * 28.08, T31 As Variant = T3 * 28.08, W31 As Variant = W3 * 28.08, H31 As Variant = H3 * 28.08 '
Const L41 As Variant = L4 * 28.08
For l = 1 To m 'sheet循环
Application.ScreenUpdating = False '关闭屏幕更新
Sheets(l).Select '选中第l个sheets（类似于鼠标点选），选中目标sheets后，所有的操作均在当前sheets中执行
For j = 1 To n '绘图数循环
Set ch = ActiveSheet.ChartObjects.Add(10 + 300 * (j - 1), 200 + 10 * (j - 1), W11, H11) '定义ch为当前sheets中的图表对象（active前缀即表示当前对象）
ch.Select '选择ch
ActiveChart.ChartType = xlXYScatterSmoothNoMarkers '图表类型为XY散点平滑曲线（无标记点）
With ActiveChart.ChartArea '图表外框尺寸
.Width = W11 '宽
.Height = H11 '高
End With
'----------------------with语法---------------------'
'with仅代表一种简写形式，上述代码去掉with的表述为：
'ActiveChart.ChartArea.Width = W11
'ActiveChart.ChartArea.Height = H11
'--------------------------------------------------------'
'----------------------绘图区设置---------------------'
With ActiveChart.PlotArea '绘图区设置
.Width = W21 '宽
.Left = L21 '左边距
.Top = T21 '顶边距
.Height = H21 '高
.Format.Line.Visible = msoTrue '绘图区边框（可见）
.Border.LineStyle = xlSolid '边框线性（实线）
.Format.Line.ForeColor.RGB = RGB(0, 0, 0) '边框颜色（黑色）
End With
'--------------------------------------------------------'
'----------------------Y轴多条曲线绘制---------------------'
For i = 1 To k ''绘图数循环，k组数据，引用数据绘图
ActiveChart.SeriesCollection.NewSeries '新建数据列
ActiveChart.FullSeriesCollection(i).Name = Name(i - 1) '数据系列名
ActiveChart.FullSeriesCollection(i).XValues = Range(Cells(r_start, c_start + dataSet_space * (j - 1)), Cells(r_end, c_start + dataSet_space * (j - 1))) 'X值（3 + (i - 1) * 24行1列单元格到20 + 3 + (i - 1) * 24行1列单元格之间的数据）
ActiveChart.FullSeriesCollection(i).Values = Range(Cells(r_start, i + c_start + dataSet_space * (j - 1)), Cells(r_end, i + c_start + dataSet_space * (j - 1))) 'Y值（3 + (i - 1) * 24行 j * 2列单元格到20 + 3 + (i - 1) * 24行 j * 2列单元格之间的数据）
ActiveChart.FullSeriesCollection(i).Format.Line.Weight = LineWeight
Next
'--------------------------------------------------------'
'----------------------次Y轴曲线绘制及线条设置---------------------'
ActiveChart.SeriesCollection.NewSeries '新建一个数据系列，表示为SeriesCollection(1)
ActiveChart.FullSeriesCollection(k + 1).Name = Name(k) '数组中第一个数编号为0，故Name(4)的值为断面地形
ActiveChart.FullSeriesCollection(k + 1).XValues = Range(Cells(r_start, c_start + k + 1 + dataSet_space * (j - 1)), Cells(r_end, c_start + k + 1 + dataSet_space * (j - 1))) 'X值（3行12列单元格到365行12列单元格之间的数据）
ActiveChart.FullSeriesCollection(k + 1).Values = Range(Cells(r_start, c_start + k + 2 + dataSet_space * (j - 1)), Cells(r_end, c_start + k + 2 + dataSet_space * (j - 1))) 'Y值（3行13列单元格到365行13列单元格之间的数据）
ActiveChart.FullSeriesCollection(k + 1).AxisGroup = xlSecondary '将数据系列设置为次Y坐标轴
With ActiveChart.FullSeriesCollection(k + 1) '修改系列（k）的颜色、设置数据标记、线宽
.Format.Line.Weight = LineWeight
.MarkerStyle = 0 '无数据标记
'.MarkerSize = MarkSize
.Format.Line.ForeColor.RGB = RGB(0, 0, 0)
End With
'--------------------------------------------------------'
'----------------------数据系列曲线设置---------------------'
'With ActiveChart.FullSeriesCollection(2) '修改系列（2）的颜色、设置数据标记、线宽
'.Format.Line.Weight = LineWeight '线宽值在图表格式修改区修改
'.MarkerStyle = 1 '标记样式可修改为其他数字
'.MarkerSize = MarkerSize '标记大小在图表格式修改区修改
'.Format.Line.ForeColor.RGB = RGB(255, 0, 0) '线条颜色在此处修改
'.Format.Fill.ForeColor.RGB = RGB(255, 0, 0) '标记颜色在此处修改
'.Format.Line.DashStyle = msoLineDash '线条线型在此处修改（虚线）
'End With
'With ActiveChart.FullSeriesCollection(3) '修改系列（3）的颜色、设置数据标记、线宽
'.Format.Line.Weight = LineWeight '线宽值在图表格式修改区修改
'.MarkerStyle = 2 '标记样式可修改为其他数字
'.MarkerSize = MarkerSize '标记大小在图表格式修改区修改
'.Format.Line.ForeColor.RGB = RGB(0, 176, 240) '线条颜色在此处修改
'.Format.Fill.ForeColor.RGB = RGB(0, 176, 240)
'End With
'--------------------------------------------------------------'
'----------------------标题设置---------------------'
ActiveChart.SetElement (msoElementChartTitleAboveChart) '添加标题
With ActiveChart.ChartTitle '图表标题修改
.Format.Line.Visible = msoFalse '标题边框（不可见）
.Format.TextFrame2.TextRange.Characters.Text = SheetName(l - 1) + Title(j - 1) '以Title数组的值命名图名
.Font.Name = AxeFont '标题字体
.Font.Bold = msoFalse '标题字体加粗（否）
.Font.Size = TitleSize '标题字体大小
.Left = L41 '左边距
.Top = 0 '顶边距
End With
'--------------------------------------------------------'
'----------------------图例设置---------------------'
ActiveChart.Legend.Delete '删除原始图例
With ActiveChart '图例设置
.HasLegend = True
.Legend.Font.Size = LegendSize '图例字号
.Legend.Font.ColorIndex = 0 '图例字体颜色
.Legend.Left = L31 '左边距
.Legend.Top = T31 '顶边距
.Legend.Height = H31 '高
.Legend.Width = W31 '宽
.Legend.Format.Line.Visible = msoTrue '图例边框（可见）
.Legend.Border.LineStyle = xlSolid '边框线性（实线）
.Legend.Format.Line.ForeColor.RGB = RGB(0, 0, 0) '边框颜色（黑色）
End With
'ActiveChart.Legend.LegendEntries(6).Delete '删除数据系列6的图例
'--------------------------------------------------------'
'----------------------X坐标轴修改---------------------'
With ActiveChart.Axes(xlCategory)
.MinimumScale = Xmin '最小值
'.MaximumScale = Xmax '最大值
'.MajorUnit = Xunit '主单位
'.CrossesAt = Xcross '交叉点
.HasMajorGridlines = False '关闭主要网格线
.MajorTickMark = xlInside '坐标轴标记在内部
.Format.Line.ForeColor.RGB = RGB(0, 0, 0) '坐标轴颜色
.TickLabels.Font.Size = AxesSize '坐标轴刻度字号
.HasTitle = True '坐标轴标题
.AxisTitle.Text = AxeXTitle '坐标轴标题内容
.AxisTitle.Characters.Font.Size = AxesNameSize '坐标轴标题字号
'.AxisTitle.Characters(Start:=5, Length:=1).Font.Superscript = True '坐标轴标题某一位上标
'.AxisTitle.Characters(Start:=2, Length:=1).Font.Subscript = True '坐标轴标题某一位下标
.AxisTitle.Characters.Font.Color = vbBlack '坐标轴标题颜色
.AxisTitle.Characters.Font.Bold = msoFalse '坐标轴标题加粗
.AxisTitle.Characters.Font.Name = AxeFont '坐标轴标题字体
'.AxisTitle.Left = L21 + W21
.AxisTitle.Top = W21
End With
'--------------------------------------------------------'
'----------------------Y坐标轴修改---------------------'
With ActiveChart.Axes(xlValue) 'Y坐标轴的最小值、最大值、主单位、交叉点......
.MinimumScale = ymin
.MaximumScale = ymax
.MajorUnit = yunit
.CrossesAt = ycross
.HasMajorGridlines = False
.MajorTickMark = xlInside
.Format.Line.ForeColor.RGB = RGB(0, 0, 0)
.TickLabels.Font.Size = AxesSize
.HasTitle = True
.AxisTitle.Text = AxeYTitle
.AxisTitle.Characters.Font.Size = AxesNameSize
'.AxisTitle.Characters(Start:=5, Length:=1).Font.Superscript = True
'.AxisTitle.Characters(Start:=2, Length:=1).Font.Subscript = True
.AxisTitle.Characters.Font.Color = vbBlack
.AxisTitle.Characters.Font.Bold = msoFalse
.AxisTitle.Characters.Font.Name = AxeFont
.AxisTitle.Left = 0
'.AxisTitle.Top = W21
End With
'--------------------------------------------------------'
'----------------------次Y坐标轴修改---------------------'
With ActiveChart.Axes(xlValue, xlSecondary) '次Y坐标轴的最小值、最大值、主单位、交叉点......
'.MinimumScale = Ysmin
.MaximumScale = Ysmax
.MajorUnit = Ysunit
'.CrossesAt = Yscross
.HasMajorGridlines = False
.MajorTickMark = xlTickMarkInside
.Format.Line.ForeColor.RGB = RGB(0, 0, 0)
.TickLabels.Font.Size = AxesSize
.HasTitle = True
.AxisTitle.Text = AxeYTitle1
.AxisTitle.Characters.Font.Size = AxesNameSize
'.AxisTitle.Characters(Start:=5, Length:=1).Font.Superscript = True
'.AxisTitle.Characters(Start:=2, Length:=1).Font.Subscript = True
.AxisTitle.Characters.Font.Color = vbBlack
.AxisTitle.Characters.Font.Bold = msoFalse
.AxisTitle.Characters.Font.Name = AxeFont
.AxisTitle.Left = W11
'.AxisTitle.Top = W21
End With
'--------------------------------------------------------'
Next
Next
Sheets(1).Select
End Sub
Sub del_ch()
Dim i As Integer
For i = 1 To 2
Application.ScreenUpdating = False '关闭屏幕更新
Sheets(i).Select
If ActiveSheet.ChartObjects.Count > 0 Then
ActiveSheet.ChartObjects.Delete '先删除所有图表
End If
Next
Sheets(1).Select
End Sub顺带附送批量删图代码：
Sub del_ch() Dim i As Integer For i = 1 To 12 Application.ScreenUpdating = False '关闭屏幕更新 Sheets(i).Select If ActiveSheet.ChartObjects.Count > 0 Then ActiveSheet.ChartObjects.Delete '先删除所有图表 End If Next Sheets(1).Select End Sub
上述代码循环数i是sheet个数，按需修改
祝大家生活愉快
https://blog.sciencenet.cn/blog-3503582-1355861.html
上一篇：批量修改文件名的python代码
下一篇：surfer绘制等值线代码
