Excel-VBA-批量自动制图表实例集锦

1 1 自动生成图表自动生成图表 统计报告 0925a xls 2013 9 25 Sub lqxs Dim Arr ks js nm1 nm2 dz1 dz2 Dim dz dz3 yy nm Application ScreenUpdating False Sheet3 Activate Arr a1 CurrentRegion ks 3 js UBound Arr 1 nm Sheet3 Name yy Left nm Len nm 3 nm1 图表 6 nm2 图表 4 dz A2 B js D2 E js ActiveSheet ChartObjects nm1 Activate With ActiveChart SetSourceData Source Sheets nm Range dz PlotBy xlColumns SeriesCollection 1 Select dz1 R3C2 R js C2 SeriesCollection 1 Values nm dz1 dz2 R3C4 R js C4 SeriesCollection 2 Values nm dz2 dz3 R3C5 R js C5 SeriesCollection 3 Values nm dz3 ChartTitle Select Selection Characters Text yy 月份合格率 End With ActiveSheet ChartObjects nm2 Activate With ActiveChart ChartArea Select dz H2 T2 H js 1 T js 1 SetSourceData Source Sheets nm Range dz PlotBy xlRows dz2 R js 1 C8 R js 1 C20 SeriesCollection 1 Values nm dz2 ChartTitle Select Selection Characters Text yy 月份不良趋势统计 End With Range A ks Select Application ScreenUpdating True MsgBox OK End Sub 2 2 批量插入图表批量插入图表 2010 9 27 批量绘图表 xls Sub ChartsAdd Dim myChart As ChartObject Dim i As Integer Dim R As Integer Dim m As Integer R Sheet1 Range A65536 End xlUp Row 1 m Abs Int R 4 Sheet2 ChartObjects Delete For i 1 To R Set myChart Sheet2 ChartObjects Add Left i 1 Mod m 1 350 320 Top i 1 m 1 220 210 Width 330 Height 210 With myChart Chart ChartType xlColumnClustered SetSourceData Source Sheet1 Range B2 M2 Offset i 1 PlotBy xlRows With SeriesCollection 1 XValues Sheet1 Range B1 M1 Name Sheet1 Range A2 Offset i 1 ApplyDataLabels AutoText True ShowValue True DataLabels Font Size 10 End With HasLegend False With ChartTitle Left 5 Top 1 Font Size 14 Font Name 华文行楷 End With With PlotArea Interior ColorIndex 2 PatternColorIndex 1 Pattern xlSolid End With Axes xlCategory TickLabels Font Size 10 Axes xlValue TickLabels Font Size 10 End With Next Sheet2 Select Set myChart Nothing End Sub 3 3 批量插入图表批量插入图表 2013 9 30 Sub OpenFiles Dim myX As Range Dim myY As Range Dim i j Application ScreenUpdating False ActiveSheet ChartObjects 图表 1 Activate For i 1 To ActiveChart SeriesCollection Count 序列集合对象的用法 ActiveChart SeriesCollection i Delete 删除原有的序列 Next With ActiveChart Axes xlCategory MaximumScale 100 MinimumScale 0 MajorUnit 20 MinorUnit 4 End With With ActiveChart ChartType xlXYScatterLinesNoMarkers 散点图 For i 1 To Sheet1 Range IV1 End xlToLeft Column 1 Step 2 j Sheet1 Range A65536 Offset 0 i 1 End xlUp Row Set myX Sheet1 Cells 4 i Resize j 3 1 Set myY myX Offset 0 1 With SeriesCollection NewSeries Values myY XValues myX Name Sheet1 Cells 1 i Value 序列名 MarkerStyle 4142 没有标志显示 End With Next i End With a1 Select Application ScreenUpdating True End Sub 4 4 图表对象图表对象 您可以结合使用 Add 方法和 ChartWizard 方法 添加包含工作表数据的新图表 本示例 将基于名为 Sheet1 的工作表上单元格 A1 A20 中的数据添加一个新的折线图 With Charts Add ChartWizard source Worksheets Sheet1 Range A1 A20 Gallery xlLine Title February Data End With ChartObject 对象充当 Chart 对象的容器 ChartObject 对象的属性和方法控制工作表上嵌 入图表的外观和大小 ChartObject 对象是 ChartObjects 集合的成员 ChartObjects 集合包含 单一工作表上的所有嵌入图表 使用 ChartObjects index 其中 index 是嵌入图表的索引号或名称 可以返回单个 ChartObject 对象 示例 以下示例设置名为 Sheet1 的工作表上嵌入图表 Chart 1 中的图表区图案 Worksheets Sheet1 ChartObjects 1 Chart ChartArea Format Fill Pattern msoPatternLightDownwardDiagonal 当选定嵌入图表时 其名称显示在 名称 框中 使用 Name 属性可设置或返回 ChartObject 对象的名称 以下示例对工作表 Sheet1 上的嵌入图表 Chart 1 使用了圆角 Worksheets sheet1 ChartObjects chart 1 RoundedCorners True 5 5 保持图表位置居中保持图表位置居中 by Lee1892by Lee1892 2013 12 03 Private Sub KeepSquare Dim dXDiff dYDiff dDiff Dim dXMin dXMax dYMin dYMax With ChartObjects 1 Chart With Axes xlCategory MaximumScaleIsAuto True MinimumScaleIsAuto True dXMax MaximumScale dXMin MinimumScale dXDiff dXMax dXMin End With With Axes xlValue MaximumScaleIsAuto True MinimumScaleIsAuto True dYMax MaximumScale dYMin MinimumScale dYDiff dYMax dYMin End With dDiff dXDiff If dXDiff dYDiff Then dDiff dYDiff With Axes xlCategory MaximumScale dXMax dDiff dXDiff 2 MinimumScale dXMin dDiff dXDiff 2 End With With Axes xlValue MaximumScale dYMax dDiff dYDiff 2 MinimumScale dYMin dDiff dYDiff 2 End With End With End Sub 6 6 分表 修改数据序列公式分表 修改数据序列公式 Sub lqxs Dim Sht As Worksheet Sht1 As Worksheet Dim Arr i r Arr1 ks js nm Application ScreenUpdating False Application DisplayAlerts False Set Sht1 Sheets 源表 Sht1 Activate For Each Sht In Sheets If Sht Name Sht1 Name Then Sht Delete Next Sht Arr a1 CurrentRegion For i 3 To UBound Arr If Arr i 1 Then r r 1 ReDim Preserve Arr1 1 To r Arr1 r i End If Next For i 1 To r If i r Then js Arr1 i 1 1 Else js UBound Arr End If ks Arr1 i Sht1 Copy after Sheets Sheets Count ActiveSheet Name Arr ks 1 a3 e500 ClearContents Sht1 Cells ks 1 Resize js ks 1 5 Copy a3 nm Arr ks 1 ActiveSheet ChartObjects 1 Activate With ActiveChart SetSourceData Source Sheets nm Range dz PlotBy xlColumns FullSeriesCollection 1 Select Selection Formula SERIES nm R2C4 nm R3C1 R js ks 3 C2 nm R3C4 R js ks 3 C4 1 FullSeriesCollection 2 Select Selection Formula SERIES nm R2C5 nm R3C1 R js ks 3 C2 nm R3C5 R js ks 3 C5 2 FullSeriesCollection 3 Delete FullSeriesCollection 3 Delete End With Next Application DisplayAlerts True Application ScreenUpdating True End Sub 7 7 自动制作多图表自动制作多图表 2012 9 13 Sub ChartsAdd Dim myChart As ChartObject Dim i As Integer Dim R As Integer R Int Sheet1 Range A65536 End xlUp Row 1 20 ActiveSheet ChartObjects Delete For i 1 To R Set myChart Sheet1 ChartObjects Add Left 200 Top i 1 260 20 Width 330 Height 210 With myChart Chart ChartType xlColumnClustered SetSourceData Source Cells 20 i 18 1 Resize 20 2 End With Next Set myChart Nothing End Sub 2014 5 4 Sub ChartsAdd Dim myChart As ChartObject Dim Myc i On Error Resume Next Myc iv3 End xlToLeft Column nm ActiveSheet Name ActiveSheet ChartObjects Delete For i 1 To Myc Step 8 Set myChart ActiveSheet ChartObjects Add Left Cells 3 i Left Top Cells 3 i Top Width Cells 3 i Resize 1 7 Width Height Cells 3 i Resize 16 1 Height With myChart Chart ChartType xlXYScatterLinesNoMarkers 散点图 SetSourceData Source Cells 550 i 1 Resize 1351 2 End With myChart Activate With ActiveChart FullSeriesCollection 1 Select FullSeriesCollection 1 XValues nm Cells 550 i 2 Resize 1351 1 Address FullSeriesCollection 1 Values nm Cells 550 i 1 Resize 1351 1 Address FullSeriesCollection 1 Name nm Cells 2 i 1 Address SeriesCollection NewSeries FullSeriesCollection 2 XValues nm Cells 550 i 6 Resize 1351 1 Address FullSeriesCollection 2 Values nm Cells 550 i 5 Resize 1351 1 Address FullSeriesCollection 2 Name nm Cells 2 i 5 Address Axes xlValue MaximumScale 500 Axes xlValue MinimumScale 200 Axes xlValue MajorUnit 100 Axes xlValue MinorUnit 20 2 Axes xlCategory MinimumScale 0 000005 Axes xlCategory MaximumScale 0 00003 Axes xlCategory MajorUnit 0 000005 Axes xlCategory MinorUnit 0 000001 Legend Position xlBottom SetElement msoElementChartTitleAboveChart ChartTitle Text Cells 1 i Value With ChartTitle Format TextFrame2 TextRange Font Size 14 End With End With Next Set myChart Nothing End Sub 8 8 自动生成图表自动生成图表 2014 8 5 Sub lqxs Dim Myr bt Myr Cells Rows Count 1 End xlUp Row ActiveSheet ChartObjects Delete ActiveSheet ChartObjects Add Left g3 Left Top g3 Top Width g3 Resize 1 7 Width Height g3 Resize 16 1 Height ActiveSheet ChartObjects 1 Activate With ActiveChart ChartType xlXYScatterSmoothNoMarkers SetSourceData Source Sheets CHART Range A3 B Myr PlotBy xlColumns SeriesCollection NewSeries SeriesCollection 1 XValues CHART R3C4 R Myr C4 SeriesCollection 1 Values CHART R3C2 R Myr C2 SeriesCollection 1 Name CHART R2C2 SeriesCollection 2 XValues CHART R3C4 R Myr C4 SeriesCollection 2 Values CHART R3C1 R Myr C1 SeriesCollection 2 Name CHART R2C1 HasTitle True bt ActiveSheet TextBox1 Text ChartTitle Characters Text bt Axes xlCategory xlPrimary HasTitle True Axes xlCategory xlPrimary AxisTitle Characters Text ActiveSheet ComboBox2 Text Axes xlValue xlPrimary HasTitle True Axes xlValue xlPrimary AxisTitle Characters Text ActiveSheet ComboBox1 Text Axes xlValue MajorUnit 1 ChartTitle Select With Selection Font FontStyle 加粗 Size 18 End With PlotArea Select With Selection Border Weight xlThin LineStyle xlNone End With Selection Interior ColorIndex xlNone End With Range a1 Select End Sub 9 9 自动制作多图表自动制作多图表 2014 9 28 Sub lqxs Dim myChart As ChartObject Arr i mx mn lf ActiveSheet ChartObjects Delete Arr a1 CurrentRegion For i 1 To UBound Arr 2 lf Cells 1 UBound Arr 2 2 Left mx Application Max Cells 1 i Resize UBound Arr 1 mn Application Min Cells 1 i Resize UBound Arr 1 Set myChart ActiveSheet ChartObjects Add Left lf Top i 1 220 10 Width 450 Height 210 With myChart Chart ChartType xlLine 折线图 SetSourceData Source Cells 1 i Resize UBound Arr 1 PlotBy xlColumns HasLegend True HasTitle False Axes xlValue MajorUnit 10 主要分尺寸 Axes xlValue MinimumScale Int mn 10 10 10 最小值 Axes xlValue MaximumScale Int mx 10 10 10 最大值 End With Next End Sub 10 10 根据指定级别自动制作多图表根据指定级别自动制作多图表 2015 4 23 Private Sub Worksheet Change ByVal Target As Range If Target Address O 1 Then Exit Sub Dim Arr i m j Dim d k t tt ks js aa c1 c2 c3 Set d CreateObject Scripting Dictionary Arr a1 CurrentRegion For i 2 To UBound Arr d Arr i 2 d Arr i 2 i Next k d keys tt d items If d exists Target Value Then t d Target Value m Application Match Target Value k 0 1 t Left t Len t 1 If InStr t Then aa Split t ks aa 0 js aa UBound aa For j 2 To 6 ActiveSheet ChartObjects 图表 j Activate Select