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

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

相关推荐
tedcloud12311 小时前
Orca 部署指南：开源 AI 推理服务的 Linux 部署实践
linux·运维·服务器·人工智能·开源·自动化·excel
星雨流星天的笔记本1 天前
0.0用excel拆分数据
excel
蓝创工坊Blue Foundry1 天前
PaddleOCR 本地部署教程：小模型 OCR 如何完成字段提取到 Excel
pdf·自动化·ocr·excel·paddlepaddle·paddle
wujian83111 天前
怎么用AI做excel表格 AI导出鸭来救场
人工智能·ai·excel·豆包·deepseek·ai导出鸭
用户298698530141 天前
React 前端处理 Excel 工作表复制的技术实践
javascript·react.js·excel
蓝创工坊Blue Foundry2 天前
个人藏书太多怎么整理？用 OCR 字段提取汇总成电子书目
pdf·ocr·excel·文心一言·paddlepaddle·paddle
蓝创工坊Blue Foundry3 天前
扫描件批量转 Excel：先确认要整表还原还是字段汇总
python·pdf·ocr·excel
Dylan的码园3 天前
从Excel到数据库：数据分析全流程与Kettle ETL实战指南
数据库·数据分析·excel
元Y亨H3 天前
Pandas 解析 Excel 导致的内存溢出（MemoryError）
python·excel
热门推荐
01GitHub 镜像站点02如何新建文件夹？ 电脑新建文件夹的4种方法032026年7月AI圈大地震：GPT-5.6被政府限制、Claude入驻Slack、Anthropic自研芯片04国内可直接用、免费额度/永久免费的大模型API清单（含 SiliconFlow、火山、阿里、智谱、百度、Kimi、DeepSeek、DMXAPI 等）05AI科技热点日报 | 2026年07月01日06微信历史版本含下载地址（ Windows PC | 安卓 | MAC ）及设置微信不更新07AI 编程 IDE 全景解析 2026：Agent 全面接管开发链路082026 国产 AI 大模型横评：DeepSeek、通义千问、Kimi、文心一言、星火、豆包谁更能打？09幻兽帕鲁 - 服务器管理员权限与 GM 命令完全指南10CC-Switch & Claude 基于 Linux 服务器安装使用指南