Excel VBA_批量自动制图表实例集锦.doc

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, 批量插入图表
‘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, 批量插入图表
‘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, 图表对象

您可以结合使用 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, 保持图表位置居中 by: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, 分表，修改数据序列公式
‘

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, 自动制作多图表
‘
‘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, 自动生成图表
‘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, 自动制作多图表
‘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, 根据指定级别自动制作多图表
‘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 Case j
Case 2
c1 = 4: c2 = 5: c3 = 6
Case 3
c1 = 6: c2 = 7: c3 = 8
Case 4
c1 = 6: c2 = 7: c3 = 9
Case 5
c1 = 6: c2 = 7: c3 = 10
Case 6
c1 = 6: c2 = 7: c3 = 11
End Select
With ActiveChart
.PlotArea.Select
.ChartType = xlBubble
.SeriesCollection(1).XValues = "=统计!R" & ks & "C" & c1 & ":R" & js & "C" & c1
.SeriesCollection(1).Values = "=统计!R" & ks & "C" & c2 & ":R" & js & "C" & c2
.SeriesCollection(1).BubbleSizes = "=统计!R" & ks & "C" & c3 & ":R" & js & "C" & c3
.SeriesCollection(1).Name = "=统计!R" & ks & "C2"
End With
Next
End If
End If '

End Sub
11, 自动制作多图表(散点图+趋势线)
‘2015-4-30
‘
Sub ChartsAdd_lqxs()
Dim myChart As ChartObject
Dim i&, R&
R = Int(Sheet1.Range("A65536").End(xlUp).Row - 1) / 6
ht = [a2:a16].Height: wt = [f1:l1].Width
ActiveSheet.ChartObjects.Delete
For i =