ExcelVBA批量自动制图表实例集锦.docx
- 文档编号:27624635
- 上传时间:2023-07-03
- 格式:DOCX
- 页数:17
- 大小:65.85KB
ExcelVBA批量自动制图表实例集锦.docx
《ExcelVBA批量自动制图表实例集锦.docx》由会员分享,可在线阅读,更多相关《ExcelVBA批量自动制图表实例集锦.docx(17页珍藏版)》请在冰豆网上搜索。
ExcelVBA批量自动制图表实例集锦
1,自动生成图表
‘8346-1-1.html
‘统计报告0925a.xls
‘2013-9-25
Sublqxs()
DimArr,ks,js,nm1$,nm2$,dz1$,dz2$
Dimdz$,dz3$,yy$,nm$
Application.ScreenUpdating=False
Arr=[a1].CurrentRegion
ks=3:
js=UBound(Arr)-1
yy=Left(nm,Len(nm)-3)
nm1="图表6"
nm2="图表4"
dz="A2:
B"&js&",D2:
E"&js
ActiveSheet.ChartObjects(nm1).Activate
WithActiveChart
.SetSourceDataSource:
=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
Selection.Characters.Text=yy&"月份合格率"
EndWith
ActiveSheet.ChartObjects(nm2).Activate
WithActiveChart
dz="H2:
T2,H"&js+1&":
T"&js+1
.SetSourceDataSource:
=Sheets(nm).Range(dz),PlotBy:
=_
xlRows
dz2="R"&js+1&"C8:
R"&js+1&"C20"
.SeriesCollection
(1).Values="='"&nm&"'!
"&dz2
Selection.Characters.Text=yy&"月份不良趋势统计"
EndWith
Range("A"&ks).Select
Application.ScreenUpdating=True
MsgBox"OK"
EndSub
2,批量插入图表
‘2010-9-27
‘
SubChartsAdd()
DimmyChartAsChartObject
DimiAsInteger
DimRAsInteger
DimmAsInteger
R=Sheet1.Range("A65536").End(xlUp).Row-1
m=Abs(Int(-(R/4)))
Fori=1ToR
SetmyChart=Sheet2.ChartObjects.Add_
(Left:
=(((i-1)Modm)+1)*350-320,_
Top:
=((i-1)\m+1)*220-210,_
Width:
=330,Height:
=210)
.ChartType=xlColumnClustered
.SetSourceDataSource:
=Sheet1.Range("B2:
M2").Offset(i-1),_
PlotBy:
=xlRows
With.SeriesCollection
(1)
.XValues=Sheet1.Range("B1:
M1")
.Name=Sheet1.Range("A2").Offset(i-1)
.ApplyDataLabelsAutoText:
=True,ShowValue:
=True
.DataLabels.Font.Size=10
EndWith
.HasLegend=False
With.ChartTitle
.Left=5
.Top=1
.Font.Size=14
.Font.Name="华文行楷"
EndWith
.ColorIndex=2
.PatternColorIndex=1
.Pattern=xlSolid
EndWith
.Axes(xlCategory).TickLabels.Font.Size=10
.Axes(xlValue).TickLabels.Font.Size=10
EndWith
Next
SetmyChart=Nothing
EndSub
3,批量插入图表
‘2013-9-30
‘:
//
SubOpenFiles()
DimmyXAsRange
DimmyYAsRange
Dimi%,j&
Application.ScreenUpdating=False
ActiveSheet.ChartObjects("图表1").Activate
‘序列集合对象的用法
ActiveChart.SeriesCollection(i).Delete‘删除原有的序列
Next
WithActiveChart.Axes(xlCategory)
.MaximumScale=100
.MinimumScale=0
.MajorUnit=20
.MinorUnit=4
EndWith
WithActiveChart
.ChartType=xlXYScatterLinesNoMarkers‘散点图
Fori=1ToSheet1.Range("IV1").End(xlToLeft).Column+1Step2
j=Sheet1.Range("A65536").Offset(0,i-1).End(xlUp).Row
SetmyX=Sheet1.Cells(4,i).Resize(j-3,1)
SetmyY=myX.Offset(0,1)
.Values=myY
.XValues=myX
.Name=Sheet1.Cells(1,i).Value‘序列名
.MarkerStyle=-4142‘没有标志显示
EndWith
Nexti
EndWith
[a1].Select
Application.ScreenUpdating=True
EndSub
4,图表对象
您可以结合使用Add方法和ChartWizard方法,添加包含工作表数据的新图表。
本例如将基于名为Sheet1的工作表上单元格A1:
A20中的数据添加一个新的折线图。
.ChartWizardsource:
=Worksheets("Sheet1").Range("A1:
A20"),_
Gallery:
=xlLine,Title:
="FebruaryData"
EndWith
ChartObject对象充当Chart对象的容器。
ChartObject对象的属性和方法控制工作表上嵌入图表的外观和大小。
ChartObject对象是ChartObjects集合的成员。
ChartObjects集合包含单一工作表上的所有嵌入图表。
使用ChartObjects(index)〔其中index是嵌入图表的索引号或名称〕可以返回单个ChartObject对象。
例如
以下例如设置名为“Sheet1”的工作表上嵌入图表Chart1中的图表区图案。
Worksheets("Sheet1").ChartObjects
(1).Chart._
ChartArea.Format.Fill.Pattern=msoPatternLightDownwardDiagonal
当选定嵌入图表时,其名称显示在“名称”框中。
使用Name属性可设置或返回ChartObject对象的名称。
以下例如对工作表“Sheet1”上的嵌入图表“Chart1”使用了圆角。
Worksheets("sheet1").ChartObjects("chart1").RoundedCorners=True
5,保持图表位置居中by:
Lee1892
‘2013-12-03
PrivateSubKeepSquare()
DimdXDiff#,dYDiff#,dDiff#
DimdXMin#,dXMax#,dYMin#,dYMax#
WithChartObjects
(1).Chart
With.Axes(xlCategory)
.MaximumScaleIsAuto=True
.MinimumScaleIsAuto=True
dXMax=.MaximumScale:
dXMin=.MinimumScale
dXDiff=dXMax-dXMin
EndWith
With.Axes(xlValue)
.MaximumScaleIsAuto=True
.MinimumScaleIsAuto=True
dYMax=.MaximumScale:
dYMin=.MinimumScale
dYDiff=dYMax-dYMin
EndWith
dDiff=dXDiff
IfdXDiff With.Axes(xlCategory) .MaximumScale=dXMax+(dDiff-dXDiff)/2 .MinimumScale=dXMin-(dDiff-dXDiff)/2 EndWith With.Axes(xlValue) .MaximumScale=dYMax+(dDiff-dYDiff)/2 .MinimumScale=dYMin-(dDiff-dYDiff)/2 EndWith EndWith EndSub 6,分表,修改数据序列公式 ‘0811-1-1.html Sublqxs() DimShtAsWorksheet,Sht1AsWorksheet DimArr,i&,r%,Arr1(),ks,js,nm$ Application.ScreenUpdating=False Application.DisplayAlerts=False SetSht1=Sheets("源表") ForEachShtInSheets NextSht Arr=[a1].CurrentRegion Fori=3ToUBound(Arr) IfArr(i,1)<>""Then r=r+1 ReDimPreserveArr1(1Tor) Arr1(r)=i EndIf Next Fori=1Tor Ifi<>rThen js=Arr1(i+1)-1 Else js=UBound(Arr) EndIf ks=Arr1(i) Sht1.Copyafter: =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 WithActiveChart .SetSourceDataSource: =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 EndWith Next Application.DisplayAlerts=True Application.ScreenUpdating=True EndSub 7,自动制作多图表 ‘9757-1-1.html ‘2012-9-13 SubChartsAdd() DimmyChartAsChartObject DimiAsInteger DimRAsInteger R=Int(Sheet1.Range("A65536").End(xlUp).Row-1)/20 Fori=1ToR SetmyChart=Sheet1.ChartObjects.Add_ (Left: =200,_ Top: =(i-1)*260+20,_ Width: =330,Height: =210) .ChartType=xlColumnClustered .SetSourceDataSource: =Cells(20*i-18,1).Resize(20,2) EndWith Next SetmyChart=Nothing EndSub ‘2014-5-4 ‘8085-1-1.html SubChartsAdd() DimmyChartAsChartObject DimMyc%,i& OnErrorResumeNext Myc=[iv3].End(xlToLeft).Column Fori=1ToMycStep8 SetmyChart=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) .ChartType=xlXYScatterLinesNoMarkers'散点图 .SetSourceDataSource: =Cells(550,i+1).Resize(1351,2) EndWith WithActiveChart .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 .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 .Legend.Position=xlBottom .SetElement(msoElementChartTitleAboveChart) .ChartTitle.Text=Cells(1,i).Value .Size=14 EndWith EndWith Next SetmyChart=Nothing EndSub 8,自动生成图表 ‘2014-8-5 ‘2829-1-1.html Sublqxs() DimMyr&,bt$ Myr=Cells(Rows.Count,1).End(xlUp).Row ActiveSheet.ChartObjects.AddLeft: =[g3].Left,_ Top: =[g3].Top,_ Width: =[g3].Resize(1,7).Width,Height: =[g3].Resize(16,1).Height ActiveSheet.ChartObjects (1).Activate WithActiveChart .ChartType=xlXYScatterSmoothNoMarkers .SetSourceDataSource: =Sheets("CHART").Range("A3: B"&Myr),PlotBy_ : =xlColumns .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" .ChartTitle.Characters.Text=bt .Axes(xlCategory,xlPrimary).HasTitle=True .Axes(xlValue,xlPrimary).HasTitle=True .Axes(xlValue).MajorUnit=1 .FontStyle="加粗" .Size=18 EndWith .Weight=xlThin .LineStyle=xlNone EndWith Selection.Interior.ColorIndex=xlNone EndWith Range("a1").Select EndSub 9,自动制作多图表 ‘2014-9-28 ‘5286-1-1.html Sublqxs() DimmyChartAsChartObject,Arr,i&,mx,mn,lf Arr=[a1].CurrentRegion Fori=1ToUBound(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)) SetmyChart=ActiveSheet.ChartObjects.Add_ (Left: =lf,Top: =(i-1)*220+10,_ Width: =450,Height: =210) .ChartType=xlLine‘折线图 .SetSourceDataSource: =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‘最大值 EndWith Next EndSub 10,根据指定级别自动制作多图表 ‘2015-4-23 ‘: //excelpx/thread-342019-1-1.html PrivateSubWorksheet_Change(ByValTargetAsRange) IfTarget.Address<>"$O$1"ThenExitSub DimArr,i&,m&,j& Dimd,k,t,tt,ks,js,aa,c1%,c2%,c3% Setd=CreateObject("Scripting.Dictionary") Arr=[a1].CurrentRe
- 配套讲稿:
如PPT文件的首页显示word图标,表示该PPT已包含配套word讲稿。双击word图标可打开word文档。
- 特殊限制:
部分文档作品中含有的国旗、国徽等图片,仅作为作品整体效果示例展示,禁止商用。设计者仅对作品中独创性部分享有著作权。
- 关 键 词:
- ExcelVBA 批量 自动 制图 实例 集锦
![提示](https://static.bdocx.com/images/bang_tan.gif)