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

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

相关推荐
SL-staff12 分钟前
规则引擎如何实现风控报告的自动化？JVS-Rules提供解决方案
大数据·自动化·excel·规则引擎·jvs-rules·风控报告·数据溯源
2501_933670791 小时前
内容电商运营岗位能力模型：SQL、Excel、投放数据与AI工具怎么准备
人工智能·sql·excel
AIGS0011 小时前
工艺参数散在Excel和纸质文件里，能不能统一管、随查随用
服务器·数据库·excel·经验沉淀·知识管理·工艺知识·本体语义
小刘在重生~2 小时前
Django｜Excel 批量上传、Form/ModelForm 文件上传、Media 媒体文件配置
python·django·excel
古少侠2 小时前
用 DS随心转 把 AI 给的表格导出成能筛选、能统计的 Excel
人工智能·excel
2601_962295333 小时前
Python自动化批量文档生成工具：Word与Excel的结合应用
python·自动化·word·excel·文档生成
昵称画2 天前
POC验证怎么设计用例？不走过程的实操要点
大数据·数据库·人工智能·低代码·excel
Wang's Blog2 天前
Vibe Coding一人即团队系列62: Excel数据分析与可视化自动化
数据分析·自动化·excel
统计学小王子2 天前
数学建模国赛倒计时5天——《软件工具（Excel）——国赛数据处理的第一道防线》
数学建模·excel
Am-Chestnuts2 天前
用 DS随心转 把 AI 对话里的多组数据批量导出成 Excel
人工智能·excel
热门推荐
01国内可直接用、免费额度/永久免费的大模型API清单（含 SiliconFlow、火山、阿里、智谱、百度、Kimi、DeepSeek、DMXAPI 等）02GitHub 镜像站点03历年考研数学一、数学二、数学三真题试卷及答案PDF04蜘蛛磁力 搜索引擎大全，如何使用蜘蛛磁力查找磁力链接052026 国产 AI 大模型横评：DeepSeek、通义千问、Kimi、文心一言、星火、豆包谁更能打？06微信历史版本含下载地址（ Windows PC | 安卓 | MAC ）及设置微信不更新07ZCode 周末送额度活动开启：3 亿 Token 免费领取08Agnes AI 免费 API 接入指南：文本、生图、生视频，一套接口全免费09AI 编程 IDE 全景解析 2026：Agent 全面接管开发链路10VSCode+CodeX扩展，无法启动