ayame的个人博客分享 http://blog.sciencenet.cn/u/ayame

博文

双Y绘图的VBA代码

已有 1569 次阅读 2022-9-18 13:41 |系统分类:科研笔记

这个是我的得意之作,代码大体修缮完毕。里面关于美化的细节问题,如有需要可自行修改相关参数。示例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绘制等值线代码
收藏 IP: 58.213.140.*| 热度|

0

该博文允许注册用户评论 请点击登录 评论 (0 个评论)

数据加载中...
扫一扫,分享此博文

Archiver|手机版|科学网 ( 京ICP备07017567号-12 )

GMT+8, 2024-3-19 17:16

Powered by ScienceNet.cn

Copyright © 2007- 中国科学报社

返回顶部