1,自动生成图表
‘http://club.excelhome.net/thread-1058346-1-1.html
‘统计报告0925a.xls
‘2013-9-25
Sublqxs()
DimArr,ks,js,nm1$,nm2$,dz1$,dz2$
Dimdz$,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
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
.ChartTitle.Select
Selection.Characters.Text=yy&"月份合格率"
EndWith
ActiveSheet.ChartObjects(nm2).Activate
WithActiveChart
.ChartArea.Select
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
.ChartTitle.Select
Selection.Characters.Text=yy&"月份不良趋势统计"
EndWith
Range("A"&ks).Select
Application.ScreenUpdating=True
MsgBox"OK"
EndSub
2,批量插入图表
‘2010-9-27
‘批量绘图表.xls
SubChartsAdd()
DimmyChartAsChartObject
DimiAsInteger
DimRAsInteger
DimmAsInteger
R=Sheet1.Range("A65536").End(xlUp).Row-1
m=Abs(Int(-(R/4)))
Sheet2.ChartObjects.Delete
Fori=1ToR
SetmyChart=Sheet2.ChartObjects.Add_
(Left:=(((i-1)Modm)+1)350-320,_
Top:=((i-1)\m+1)220-210,_
Width:=330,Height:=210)
WithmyChart.Chart
.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
With.PlotArea.Interior
.ColorIndex=2
.PatternColorIndex=1
.Pattern=xlSolid
EndWith
.Axes(xlCategory).TickLabels.Font.Size=10
.Axes(xlValue).TickLabels.Font.Size=10
EndWith
Next
Sheet2.Select
SetmyChart=Nothing
EndSub
3,批量插入图表
‘2013-9-30
‘http://club.excelhome.net/forum.php?mod=viewthread&tid=1059674&page=1#pid7221588
SubOpenFiles()
DimmyXAsRange
DimmyYAsRange
Dimi%,j&
Application.ScreenUpdating=False
ActiveSheet.ChartObjects("图表1").Activate
Fori=1ToActiveChart.SeriesCollection.Count‘序列集合对象的用法
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)
With.SeriesCollection.NewSeries
.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中的数据添加一个新的折线图。
WithCharts.Add
.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,分表，修改数据序列公式
‘http://club.excelhome.net/thread-1100811-1-1.html
Sublqxs()
DimShtAsWorksheet,Sht1AsWorksheet
DimArr,i&,r%,Arr1(),ks,js,nm$
Application.ScreenUpdating=False
Application.DisplayAlerts=False
SetSht1=Sheets("源表")
Sht1.Activate
ForEachShtInSheets
IfSht.Name<>Sht1.NameThenSht.Delete
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,自动制作多图表
‘http://club.excelhome.net/thread-919757-1-1.html
‘2012-9-13
SubChartsAdd()
DimmyChartAsChartObject
DimiAsInteger
DimRAsInteger
R=Int(Sheet1.Range("A65536").End(xlUp).Row-1)/20
ActiveSheet.ChartObjects.Delete
Fori=1ToR
SetmyChart=Sheet1.ChartObjects.Add_
(Left:=200,_
Top:=(i-1)260+20,_
Width:=330,Height:=210)
WithmyChart.Chart
.ChartType=xlColumnClustered
.SetSourceDataSource:=Cells(20i-18,1).Resize(20,2)
EndWith
Next
SetmyChart=Nothing
EndSub
‘2014-5-4
‘http://club.excelhome.net/thread-1118085-1-1.html
SubChartsAdd()
DimmyChartAsChartObject
DimMyc%,i&
OnErrorResumeNext
Myc=[iv3].End(xlToLeft).Column
nm=ActiveSheet.Name
ActiveSheet.ChartObjects.Delete
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)
WithmyChart.Chart
.ChartType=xlXYScatterLinesNoMarkers''散点图
.SetSourceDataSource:=Cells(550,i+1).Resize(1351,2)
EndWith
myChart.Activate
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
.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
EndWith
EndWith
Next
SetmyChart=Nothing
EndSub
8,自动生成图表
‘2016-1-9
‘http://club.excelhome.net/thread-1252814-1-1.html
‘2003版本
SubChartsAdd()
Dimi&,Myr&,nm$,tl1$,tl2$
Application.ScreenUpdating=False
nm="Sheet2":tl1=[b4].Value:tl2=[c4].Value
Myr=Cells(Rows.Count,1).End(xlUp).Row
ActiveSheet.ChartObjects.Delete
Fori=1ToMyr-4
ActiveSheet.ChartObjects.AddLeft:=500,_
Top:=Cells(i+4,1).Top,_
Width:=300,Height:=Cells(i+4,1).Height-5
ActiveSheet.ChartObjects(i).Activate
WithActiveChart
.ChartType=xlLineMarkers
.SeriesCollection.NewSeries
.SeriesCollection(1).XValues="=Sheet2!R1C2:R1C4"
.SeriesCollection(1).Values=_
"=(Sheet2!R"&i+4&"C2,Sheet2!R"&i+4&"C4,Sheet2!R"&i+4&"C6)"
.SeriesCollection(1).Name="=Sheet2!R4C2"
.SeriesCollection.NewSeries
.SeriesCollection(2).Values=_
"=(Sheet2!R"&i+4&"C3,Sheet2!R"&i+4&"C5,Sheet2!R"&i+4&"C7)"
.SeriesCollection(2).Name="=Sheet2!R4C3"
.HasTitle=True
.ChartTitle.Characters.Text=Sheet2.Cells(i+4,1).Value
.ChartTitle.Select
WithSelection.Font
.FontStyle="加粗"
.Size=14
EndWith
.PlotArea.Select
WithSelection.Border
.LineStyle=xlNone
EndWith
Selection.Interior.ColorIndex=xlNone
.Legend.Select
WithSelection.Border
.LineStyle=xlNone
EndWith
EndWith
Sheet2.Cells(i+4,1).Select
Next
Application.ScreenUpdating=True
EndSub
‘2014-8-5
‘http://club.excelhome.net/thread-1142829-1-1.html
Sublqxs()
DimMyr&,bt$
Myr=Cells(Rows.Count,1).End(xlUp).Row
ActiveSheet.ChartObjects.Delete
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.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
WithSelection.Font
.FontStyle="加粗"
.Size=18
EndWith
.PlotArea.Select
WithSelection.Border
.Weight=xlThin
.LineStyle=xlNone
EndWith
Selection.Interior.ColorIndex=xlNone
EndWith
Range("a1").Select
EndSub
9,自动制作多图表
‘2014-9-28
‘http://club.excelhome.net/thread-1155286-1-1.html
Sublqxs()
DimmyChartAsChartObject,Arr,i&,mx,mn,lf
ActiveSheet.ChartObjects.Delete
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)
WithmyChart.Chart
.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
‘http://www.excelpx.com/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].CurrentRegion
Fori=2ToUBound(Arr)
d(Arr(i,2))=d(Arr(i,2))&i&","
Next
k=d.keys:tt=d.items
Ifd.exists(Target.Value)Then
t=d(Target.Value)
m=Application.Match(Target.Value,k,0)+1
t=Left(t,Len(t)-1)
IfInStr(t,",")Then
aa=Split(t,",")
ks=aa(0):js=aa(UBound(aa))
Forj=2To6
ActiveSheet.ChartObjects("图表"&j).Activate
SelectCasej
Case2
c1=4:c2=5:c3=6
Case3
c1=6:c2=7:c3=8
Case4
c1=6:c2=7:c3=9
Case5
c1=6:c2=7:c3=10
Case6
c1=6:c2=7:c3=11
EndSelect
WithActiveChart
.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"
EndWith
Next
EndIf
EndIf''
EndSub
11,自动制作多图表(散点图+趋势线)
‘2015-4-30
‘http://www.excelpx.com/thread-342407-1-1.html
SubChartsAdd_lqxs()
DimmyChartAsChartObject
Dimi&,R&
R=Int(Sheet1.Range("A65536").End(xlUp).Row-1)/6
ht=[a2:a16].Height:wt=[f1:l1].Width
ActiveSheet.ChartObjects.Delete
Fori=1ToR
SetmyChart=Sheet1.ChartObjects.Add_
(Left:=[f1].Left,_
Top:=(i-1)210,_
Width:=wt,Height:=ht)
WithmyChart.Chart
.ChartType=xlXYScatter
.SetSourceDataSource:=Cells(6i-4,1).Resize(5,2)
.FullSeriesCollection(1).Trendlines.Add
.FullSeriesCollection(1).Trendlines(1).Select
WithSelection
.Type=xlPolynomial
.Order=3
EndWith
Selection.DisplayEquation=True
Selection.DisplayRSquared=True
EndWith
Next
SetmyChart=Nothing
EndSub
|
|
