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

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

相关推荐
ailitsoft2 天前
库存管理系统如何记录跨门店调拨后的收货差异？
excel·零售·软件需求
百事牛科技3 天前
Excel的三种密码：防看、防存、防乱改，各管各的
windows·excel
用户298698530143 天前
React 前端将 Excel 工作表导出为图片的技术实践
javascript·react.js·excel
用户0332126663674 天前
使用 Python 在 Excel 文档中添加水印
python·excel
科技新资讯6 天前
AI如何批量处理Excel文件？ 从数据合并、清洗到自动生成报表，看看 AI Agent 怎么完成任务
大数据·人工智能·excel
用户0332126663676 天前
使用 Python 在 Excel 中添加与删除筛选器
python·excel
xurime6 天前
Excelize 开源基础库发布 2.11.1 版本更新
数据分析·excel·开源软件·excelize·gitcode
梦想出海-Phoebe6 天前
Gemini新增文件编辑功能：PDF、Word、Excel处理体验分享
pdf·word·excel
Data-Miner7 天前
AI和Excel怎么结合才能真提效
人工智能·excel
taller_20008 天前
【012】数据类型入门: Excel 数据到 Python 值的转换
python·excel·pie·py
热门推荐
01国内可直接用、免费额度/永久免费的大模型API清单（含 SiliconFlow、火山、阿里、智谱、百度、Kimi、DeepSeek、DMXAPI 等）02如何新建文件夹？ 电脑新建文件夹的4种方法03历年考研数学一、数学二、数学三真题试卷及答案PDF04GitHub 镜像站点05几个好用的ip纯净度检测网站06苹果iPA游戏软件资源下载网站07微信历史版本含下载地址（ Windows PC | 安卓 | MAC ）及设置微信不更新08蜘蛛磁力 搜索引擎大全，如何使用蜘蛛磁力查找磁力链接09昇腾910B系列芯片完全指南：四款型号对比、服务器选型与大模型部署实战10Dify：一站式AI应用开发平台全解析与Windows部署指南