ExcelVBA_批量自动制图表实例集锦
1, 自动生成图表
-1058346-1-1.html
统计报告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 = https://www.wendangku.net/doc/a81824868.html, 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
= 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
= yy & " 月份不良趋势统计End With
Range("A" & ks).Select
Applicati on. Scree nU pdat ing = True MsgBox "OK"
End Sub
2, 批量插入图表
‘2010-9-27
‘批量绘图表.xls
Sub ChartsAdd()
Dim myChart As ChartObject
Dim i As Integer
Dim R As Integer 8月粉不良趋势统计
2500
2000
1EOO
1000
500
98 50%
96 00%
97.50%
97.00%
96.50%
96 ￡0%
95 50%
95.00%
94 50%
94.00%
Dim m As Integer
R = Sheet1.Range("A65536").End(xlUp).Row - 1
m = Abs(Int(-(R / 4)))
For i = 1 To R
Set myChart = _
(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 . = 10
End With
.HasLegend = False
With .ChartTitle
.Left = 5
.Top = 1
.Font.Size = 14
https://www.wendangku.net/doc/a81824868.html, = " 华文行楷" End With With .PlotArea.Interior
.ColorIndex = 2
.PatternColorIndex = 1 .Pattern = xlSolid End With .Axes(xlCategory). =
10 .Axes(xlValue). = 10
End With
Next
Sheet2.Select
Set myChart = Nothing
End Sub
3, 批量插入图表
‘2013-9-30
‘#pid7221588
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(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 对象。
示例
以下示例设置名为"Sheetl ”的工作表上嵌入图表Chart 1中的图表区图案。
Worksheets("Sheet1").ChartObjects(1).Chart. _
= msoPatternLightDownwardDiagonal
当选定嵌入图表时，其名称显示在“名称”框中。使用Name 属性可设置或返回ChartObject 对象的名称。以下示例对工作表“ Sheetl”上的嵌入图表“ Chart 1 ”使用了圆角。
Worksheets("sheet1").ChartObjects("chart 1").RoundedCorners = True
5, 保持图表位置居中by:Lee1892
‘ 201-312-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, 分表，修改数据序列公式
‘-1100811-1-1.html
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 https://www.wendangku.net/doc/a81824868.html, <> https://www.wendangku.net/doc/a81824868.html, 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)
https://www.wendangku.net/doc/a81824868.html, = 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, 自动制作多图表
-919757-1-1.html
‘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
For i = 1 To R
Set myChart = _
(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