excel中使用宏绘制折线图

石马马户2026-07-28 14:08
vbnet 复制代码 
   
   Sub A_5连续按压sheet绘制2个折线图()
   
   
   
   '1cm是23.75点左右
    Dim ws As Worksheet
    Dim chartObj As ChartObject
    Dim chartObj1 As ChartObject, chartObj2 As ChartObject
    Dim rng1 As Range
    Dim series As series
    
    ' ====== 选择 "连续按压图表" 这个工作表 ======
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("连续按压图表")
    On Error GoTo 0
    
    ' 如果工作表不存在，提示错误并退出
    If ws Is Nothing Then
        MsgBox "未找到工作表：连续按压图表", vbExclamation, "错误"
        Exit Sub
    End If

    ' ====== 清除当前 Sheet 内所有图表 ======
    For Each chartObj In ws.ChartObjects
        chartObj.Delete
    Next chartObj
If 0 Then
    ' ====== 第一个图表 ======
    Set rng1 = ws.Range("A1:M3")
    Set chartObj1 = ws.ChartObjects.Add(Left:=ws.Range("A10").Left, Top:=ws.Range("A10").Top, Width:=545, Height:=405)
    With chartObj1.Chart
        .ChartType = xlLineMarkers
        .SetSourceData Source:=rng1
        .HasTitle = True
        .ChartTitle.Text = ws.Range("A11").Value
        .HasLegend = True
        .Legend.Position = xlLegendPositionBottom

        ' 调整图例宽度
        .Legend.Width = 150

        ' 设置数据标记
        For Each series In .SeriesCollection
            series.MarkerStyle = xlMarkerStyleCircle
            series.MarkerSize = 6
        Next series

        ' 设置网格线
        .Axes(xlCategory).MajorGridlines.Delete
        .Axes(xlCategory).MinorGridlines.Delete
        With .Axes(xlValue).MajorGridlines.Border
            .Color = RGB(0, 0, 0)
            .LineStyle = xlContinuous
        End With
        .PlotArea.Border.LineStyle = msoLineNone
        .Axes(xlValue).Border.LineStyle = xlContinuous
        .Axes(xlValue).Border.Color = RGB(255, 255, 255)
    End With
End If

    ' ====== 第一个图表 ======
   Set chartObj1 = ws.ChartObjects.Add(Left:=ws.Range("A10").Left, Top:=ws.Range("A10").Top, Width:=545, Height:=405)
    With chartObj1.Chart
        .ChartType = xlLineMarkers
        .HasTitle = True
        .ChartTitle.Text = ws.Range("A11").Value

        ' 添加系列
        With .SeriesCollection.NewSeries
            .Name = ws.Range("A2").Value
            .Values = ws.Range("C2:M2")
            .XValues = ws.Range("C1:N1")
            .MarkerStyle = xlMarkerStyleCircle
            .MarkerSize = 6
        End With
        With .SeriesCollection.NewSeries
            .Name = ws.Range("A3").Value
            .Values = ws.Range("C3:M3")
            .XValues = ws.Range("C1:M1")
            .MarkerStyle = xlMarkerStyleCircle
            .MarkerSize = 6
        End With

        ' 图例
        .HasLegend = True
        .Legend.Position = xlLegendPositionBottom
        .Legend.Width = 150 ' 调整图例宽度

        ' 网格线
        .Axes(xlCategory).MajorGridlines.Delete
        .Axes(xlCategory).MinorGridlines.Delete
        With .Axes(xlValue).MajorGridlines.Border
            .Color = RGB(0, 0, 0)
            .LineStyle = xlContinuous
        End With
        .PlotArea.Border.LineStyle = msoLineNone
        .Axes(xlValue).Border.LineStyle = xlContinuous
        .Axes(xlValue).Border.Color = RGB(255, 255, 255)
    End With










    ' ====== 第二个图表 ======
    Set chartObj2 = ws.ChartObjects.Add(Left:=ws.Range("L10").Left, Top:=ws.Range("L10").Top, Width:=545, Height:=405)
    With chartObj2.Chart
        .ChartType = xlLineMarkers
        .HasTitle = True
        .ChartTitle.Text = ws.Range("A12").Value

        ' 添加系列
        With .SeriesCollection.NewSeries
            .Name = ws.Range("A4").Value
            .Values = ws.Range("C4:M4")
            .XValues = ws.Range("C1:M1")
            .MarkerStyle = xlMarkerStyleCircle
            .MarkerSize = 6
        End With
        With .SeriesCollection.NewSeries
            .Name = ws.Range("A5").Value
            .Values = ws.Range("C5:M5")
            .XValues = ws.Range("C1:M1")
            .MarkerStyle = xlMarkerStyleCircle
            .MarkerSize = 6
        End With

        ' 图例
        .HasLegend = True
        .Legend.Position = xlLegendPositionBottom
        .Legend.Width = 150 ' 调整图例宽度

        ' 网格线
        .Axes(xlCategory).MajorGridlines.Delete
        .Axes(xlCategory).MinorGridlines.Delete
        With .Axes(xlValue).MajorGridlines.Border
            .Color = RGB(0, 0, 0)
            .LineStyle = xlContinuous
        End With
        .PlotArea.Border.LineStyle = msoLineNone
        .Axes(xlValue).Border.LineStyle = xlContinuous
        .Axes(xlValue).Border.Color = RGB(255, 255, 255)
    End With

    ' ====== 缩放图表 ======
    ' 第一个图表缩放
    chartObj1.ShapeRange.LockAspectRatio = msoFalse
    chartObj1.ShapeRange.ScaleWidth 1.2, msoFalse, msoScaleFromTopLeft ' 放大 120%
    chartObj1.ShapeRange.ScaleHeight 1.2, msoFalse, msoScaleFromTopLeft ' 放大 120%

    ' 第二个图表缩放
    chartObj2.ShapeRange.LockAspectRatio = msoFalse
    chartObj2.ShapeRange.ScaleWidth 1.2, msoFalse, msoScaleFromTopLeft ' 放大 120%
    chartObj2.ShapeRange.ScaleHeight 1.2, msoFalse, msoScaleFromTopLeft ' 放大 120%

    ' ====== 刷新并启用屏幕更新 ======
    chartObj1.Chart.Refresh
    chartObj2.Chart.Refresh
    DoEvents
    Application.ScreenUpdating = True
End Sub

   
   

 
   
   
   
   
   Sub A_4非连续按压sheet绘制4个折线图()
   
    '1cm是23.75点左右
    Dim ws As Worksheet
    Dim chartObj As ChartObject
    Dim chartObj1 As ChartObject, chartObj2 As ChartObject
    Dim chartObj3 As ChartObject, chartObj4 As ChartObject
    Dim rng1 As Range
    Dim series As series
    
    ' ====== 选择 "非连续图表" 这个工作表 ======
    On Error Resume Next
    Set ws = ThisWorkbook.Sheets("非连续图表")
    On Error GoTo 0
    
    ' 如果工作表不存在，提示错误并退出
    If ws Is Nothing Then
        MsgBox "未找到工作表：非连续图表", vbExclamation, "错误"
        Exit Sub
    End If

    ' ====== 清除当前 Sheet 内所有图表 ======
    For Each chartObj In ws.ChartObjects
        chartObj.Delete
    Next chartObj

    ' ====== 第一个图表 ======
    Set rng1 = ws.Range("A14:K16")
    Set chartObj1 = ws.ChartObjects.Add(Left:=ws.Range("A19").Left, Top:=ws.Range("A19").Top, Width:=545, Height:=405)
    With chartObj1.Chart
        .ChartType = xlLineMarkers
        .SetSourceData Source:=rng1
        .HasTitle = True
        .ChartTitle.Text = ws.Range("A19").Value
        .HasLegend = True
        .Legend.Position = xlLegendPositionBottom

        ' 调整图例宽度
        .Legend.Width = 150

        ' 设置数据标记
        For Each series In .SeriesCollection
            series.MarkerStyle = xlMarkerStyleCircle
            series.MarkerSize = 6
        Next series

        ' 设置网格线
        .Axes(xlCategory).MajorGridlines.Delete
        .Axes(xlCategory).MinorGridlines.Delete
        With .Axes(xlValue).MajorGridlines.Border
            .Color = RGB(0, 0, 0)
            .LineStyle = xlContinuous
        End With
        .PlotArea.Border.LineStyle = msoLineNone
        .Axes(xlValue).Border.LineStyle = xlContinuous
        .Axes(xlValue).Border.Color = RGB(255, 255, 255)
    End With
    
    ' ====== 第二个图表 ======
    Set chartObj2 = ws.ChartObjects.Add(Left:=ws.Range("L19").Left, Top:=ws.Range("L19").Top, Width:=545, Height:=405)
    With chartObj2.Chart
        .ChartType = xlLineMarkers
        .HasTitle = True
        .ChartTitle.Text = ws.Range("A20").Value

        ' 添加系列
        With .SeriesCollection.NewSeries
            .Name = ws.Range("A17").Value
            .Values = ws.Range("B17:K17")
            .XValues = ws.Range("B14:K14")
            .MarkerStyle = xlMarkerStyleCircle
            .MarkerSize = 6
        End With
        With .SeriesCollection.NewSeries
            .Name = ws.Range("A18").Value
            .Values = ws.Range("B18:K18")
            .XValues = ws.Range("B14:K14")
            .MarkerStyle = xlMarkerStyleCircle
            .MarkerSize = 6
        End With

        ' 图例
        .HasLegend = True
        .Legend.Position = xlLegendPositionBottom
        .Legend.Width = 150 ' 调整图例宽度

        ' 网格线
        .Axes(xlCategory).MajorGridlines.Delete
        .Axes(xlCategory).MinorGridlines.Delete
        With .Axes(xlValue).MajorGridlines.Border
            .Color = RGB(0, 0, 0)
            .LineStyle = xlContinuous
        End With
        .PlotArea.Border.LineStyle = msoLineNone
        .Axes(xlValue).Border.LineStyle = xlContinuous
        .Axes(xlValue).Border.Color = RGB(255, 255, 255)
    End With

    ' ====== 第三个图表 ======
    Set chartObj3 = ws.ChartObjects.Add(Left:=ws.Range("A63").Left, Top:=ws.Range("A63").Top, Width:=545, Height:=405)
    With chartObj3.Chart
        .ChartType = xlLineMarkers
        .HasTitle = True
        .ChartTitle.Text = ws.Range("A63").Value

        ' 添加系列
        With .SeriesCollection.NewSeries
            .Name = ws.Range("A59").Value
            .Values = ws.Range("B59:K59")
            .XValues = ws.Range("B58:K58")
            .MarkerStyle = xlMarkerStyleCircle
            .MarkerSize = 6
        End With
        With .SeriesCollection.NewSeries
            .Name = ws.Range("A60").Value
            .Values = ws.Range("B60:K60")
            .XValues = ws.Range("B58:K58")
            .MarkerStyle = xlMarkerStyleCircle
            .MarkerSize = 6
        End With

        ' 图例
        .HasLegend = True
        .Legend.Position = xlLegendPositionBottom
        .Legend.Width = 150 ' 调整图例宽度

        ' 网格线
        .Axes(xlCategory).MajorGridlines.Delete
        .Axes(xlCategory).MinorGridlines.Delete
        With .Axes(xlValue).MajorGridlines.Border
            .Color = RGB(0, 0, 0)
            .LineStyle = xlContinuous
        End With
        .PlotArea.Border.LineStyle = msoLineNone
        .Axes(xlValue).Border.LineStyle = xlContinuous
        .Axes(xlValue).Border.Color = RGB(255, 255, 255)
    End With

    ' ====== 第四个图表 ======
    Set chartObj4 = ws.ChartObjects.Add(Left:=ws.Range("L63").Left, Top:=ws.Range("L63").Top, Width:=545, Height:=405)
    With chartObj4.Chart
        .ChartType = xlLineMarkers
        .HasTitle = True
        .ChartTitle.Text = ws.Range("A64").Value

        ' 添加系列
        With .SeriesCollection.NewSeries
            .Name = ws.Range("A61").Value
            .Values = ws.Range("B61:K61")
            .XValues = ws.Range("B58:K58")
            .MarkerStyle = xlMarkerStyleCircle
            .MarkerSize = 6
        End With
        With .SeriesCollection.NewSeries
            .Name = ws.Range("A62").Value
            .Values = ws.Range("B62:K62")
            .XValues = ws.Range("B58:K58")
            .MarkerStyle = xlMarkerStyleCircle
            .MarkerSize = 6
        End With

        ' 图例
        .HasLegend = True
        .Legend.Position = xlLegendPositionBottom
        .Legend.Width = 150 ' 调整图例宽度

        ' 网格线
        .Axes(xlCategory).MajorGridlines.Delete
        .Axes(xlCategory).MinorGridlines.Delete
        With .Axes(xlValue).MajorGridlines.Border
            .Color = RGB(0, 0, 0)
            .LineStyle = xlContinuous
        End With
        .PlotArea.Border.LineStyle = msoLineNone
        .Axes(xlValue).Border.LineStyle = xlContinuous
        .Axes(xlValue).Border.Color = RGB(255, 255, 255)
    End With

    ' ====== 缩放图表 ======
    ' 第一个图表缩放
    chartObj1.ShapeRange.LockAspectRatio = msoFalse
    chartObj1.ShapeRange.ScaleWidth 1.2, msoFalse, msoScaleFromTopLeft ' 放大 120%
    chartObj1.ShapeRange.ScaleHeight 1.2, msoFalse, msoScaleFromTopLeft ' 放大 120%

    ' 第二个图表缩放
    chartObj2.ShapeRange.LockAspectRatio = msoFalse
    chartObj2.ShapeRange.ScaleWidth 1.2, msoFalse, msoScaleFromTopLeft ' 放大 120%
    chartObj2.ShapeRange.ScaleHeight 1.2, msoFalse, msoScaleFromTopLeft ' 放大 120%

    ' 第三个图表缩放
    chartObj3.ShapeRange.LockAspectRatio = msoFalse
    chartObj3.ShapeRange.ScaleWidth 1.2, msoFalse, msoScaleFromTopLeft ' 放大 120%
    chartObj3.ShapeRange.ScaleHeight 1.2, msoFalse, msoScaleFromTopLeft ' 放大 120%

    ' 第四个图表缩放
    chartObj4.ShapeRange.LockAspectRatio = msoFalse
    chartObj4.ShapeRange.ScaleWidth 1.2, msoFalse, msoScaleFromTopLeft ' 放大 120%
    chartObj4.ShapeRange.ScaleHeight 1.2, msoFalse, msoScaleFromTopLeft ' 放大 120%

    ' ====== 刷新并启用屏幕更新 ======
    chartObj1.Chart.Refresh
    chartObj2.Chart.Refresh
    chartObj3.Chart.Refresh
    chartObj4.Chart.Refresh
    DoEvents
    Application.ScreenUpdating = True
End Sub

选择不同区域绘制多个图表并设置线条颜色

相关推荐
reasonsummer1 天前
【办公类-53-12】20261016（预测）Python模仿制作2026学年第二学期校历（excel+pdf，上下学期都包含）
pdf·excel
泡海椒1 天前
JQuick-Excel 自定义 SPI Provider：用 fullName 扩展 TRANSFORM 函数
驱动开发·excel
泡海椒1 天前
从 XML 到 Excel：JQuick-Excel 代理与解析器如何协作
xml·excel
优选资讯2 天前
Excel 批量打印标签的完整流程
excel
雪宫街道2 天前
SpringBoot - POI实现Excel 导入与导出
spring boot·后端·excel
Data-Miner3 天前
数据分析，除了Excel数据透视表，还有什么工具？——2026 专业精选推荐榜
microsoft·数据分析·excel
SunnyDays10113 天前
使用 Java 高效管理 Excel 批注：添加、读取、修改和删除
java·开发语言·excel
福兮说3 天前
AI 把工号整理成 Excel 后，前面的 0 还在吗？我会先核对这三列
excel
工具派3 天前
JSON转Excel后18位订单号不对了？数字精度与类型边界实测
json·excel
热门推荐
01国内可直接用、免费额度/永久免费的大模型API清单（含 SiliconFlow、火山、阿里、智谱、百度、Kimi、DeepSeek、DMXAPI 等）02「全语录+省流版」邵艾伦 × 孙宇晨：聊风口、聊个人IP、聊年轻人如何抓住 AI 时代的机会03如何新建文件夹？ 电脑新建文件夹的4种方法04GitHub 镜像站点05历年考研数学一、数学二、数学三真题试卷及答案PDF06几个好用的ip纯净度检测网站07苹果iPA游戏软件资源下载网站08Windows 10/11 如何退出微软账户并改用本地账户登录（含找不到选项的解决方法）09蜘蛛磁力 搜索引擎大全，如何使用蜘蛛磁力查找磁力链接10Telegram APK 下载安装完整指南 — 2026年最新