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

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

相关推荐
慧都小妮子3 小时前
前端实现复杂公式计算：SpreadJS 在京东物流 Udata 平台的落地实践
javascript·数据分析·excel·数据可视化·spreadjs·前端表格控件
葡萄城技术团队12 小时前
告别宽表拖拽：SpreadJS 如何让 Web 表格承接 Excel 操作习惯
数据库·html·excel
如意机反光镜裸12 小时前
如何合并局域网共享文件夹中的多个 Excel 工作簿？（免 WPS 会员解决方案）
服务器·excel·wps
不剪发的Tony老师14 小时前
DuckDB数据分析实战：读写Excel文件
数据分析·excel·duckdb
lengjingzju2 天前
一天掌握Vim，精华使用笔记
笔记·vim·excel
灵析表格2 天前
灵析表格财务函数深度实用性分析与实操教程
开发语言·ai·json·excel·wps
杰夫（简道云个人搭建）3 天前
SAAS系统应该先解决业务问题，再优化体验
数据库·人工智能·低代码·excel·个人开发
AI导出鸭4 天前
怎么让豆包做表格？AI导出鸭苹果版将豆包输出的管道表格智能解析为二维结构，一键导出为Excel或Word标准表格。
人工智能·chatgpt·word·excel·ai导出鸭
Am-Chestnuts5 天前
AI表格复制到Excel后日期金额和编号被改写：导入与格式检查方法
excel
方渐鸿5 天前
【无标题】使用Agent总结网页信息写入Excel
ai·excel
热门推荐
01国内可直接用、免费额度/永久免费的大模型API清单（含 SiliconFlow、火山、阿里、智谱、百度、Kimi、DeepSeek、DMXAPI 等）02GitHub 镜像站点032026 国产 AI 大模型横评：DeepSeek、通义千问、Kimi、文心一言、星火、豆包谁更能打？04微信历史版本含下载地址（ Windows PC | 安卓 | MAC ）及设置微信不更新05Agnes AI 免费 API 接入指南：文本、生图、生视频，一套接口全免费06历年考研数学一、数学二、数学三真题试卷及答案PDF07VSCode+CodeX扩展，无法启动08AI 编程 IDE 全景解析 2026：Agent 全面接管开发链路092026年7月AI圈大地震：GPT-5.6被政府限制、Claude入驻Slack、Anthropic自研芯片10如何新建文件夹？ 电脑新建文件夹的4种方法