1,自動生成圖表

48346-l-l.h(ml

'統計報告0925a.xls

*2013-9-25

Sublqxs()

DimArr,ks,js,nm1$,nm2$,dz1$,dz2S

Dimdz$,dz3$,yy$.nm$

Application.ScrccnUpdating=False

Sheet3.Activate

Arr=[al].CurrentRegion

ks=3:js=UBound(Arr)-1

nm=Sheet3.Name

yy=Left(nm,Len(nm)-3)

nml="圖表6"

nm2="圖表4"

dz="A2:B"&js&",D2:E"&js

ActiveSheet.ChaitObjects(nm1).Activate

WithAcliveChart

.SetSourceDataSource:=Sheets(nni).Range(dz),PlotBy:=xlColumns

.SeriesCollection(l).Select

dzl="R3c2:R"&js&”C2”

.ScricsCollcction(I).Values=",='"&nm&&dzl

dz2="R3C^:R"&js&"C4"

.SeriesCollection(2).Vahies="=&nm&&dz2

dz3="R3C5:R"&js&"C5"

.SeriesCollection(3).Values="&nm&&dz3

.ChartTitle.Select

Selection.Characters.Texl=yy&"月份合格率"

EndWith

ActivcShcct.ChartObjccts(nm2).Activate

WithAcliveChart

.ChartArca.Select

dz="H2:T2,H”&js+I&H:T"&js+1

.SetSourceDataSource:=Sheets(nm).Range(dz),PlotBy:=_

xIRows

dz2="R"&js+1&"C8:R"&js+1&”C20”

.ScricsCollcction(1).Values="&nm&&dz2

.ChartTitle.Select

Selection.Charactcrs.Tcxt=yy&"月份不良趨勢統計”

EndWith

Range("A"&ks).Select

Application.Screenupdating=True

MsgBox"OK"

EndSub

8月份不良趨統計

8月份合格率

9850%

9800%

9750%

97.00%

96.50%

96.00%

95.50%

9500%

9450%

9400%

2,批量插入圖表

42010-9-27

'批量繪圖表.xls

SubChartsAdd()

DimniyChartAsChartObject

DimiAsInteger

DimRAsInteger

DiminAsInteger

R=SheetI.Range("A65536").End(xlUp).Row-1

m=Abs(Int(-(R/4)))

Fori=1ToR

SetmyChart=Sheet2.ChartObjects.Add_

(Left:=(((i-l)Modm)+1)*350-320,_

Top:=((i-l)\m+1)*220-210,_

Width:=33O,Height:=210)

WithmyChart.Chart

.ChartType=xlColumnClustered

.SetSourceDataSource:=Sheetl.Range("B2:M2").Offset(i-1),_

PlotBy:=xlRows

With.SeriesCollection(l)

.XValucs=Shcctl.Rangc("Bl:M1")

.Name=Sheet1.Range("A2").Offset(i-1)

.ApplyDataLabclsAutoTcxt:=Truc,Sho\vValue:=Truc

.DataLabeIs.Font.Size=10

EndWith

j=Sheetl.Range("A65536").Offset(0,i-l).End(xlUp).Row

SetmyX=Sheetl.Cells(4,i).Resize。-3,1)

SetmyY=myX.Offsct(0,1)

With.SeriesColleclion.NewSeries

.Values=myY

.XValues=myX

.Name=Sheet1.Cells(l,i).Value，序列名

.MarkerStyle=-4142，沒有標志顯示

EndWith

Nexti

EndWith

[al].Select

Application.ScreenUpdating=True

EndSub

4,圖表對象

您可以結合使用Add方法和ChartWizard方法，添加包含工作表數據的新圖表。本示例

將基于名為Sheell的工作表上單元格A1:A20中的數據添加一個新的折線圖。

WithCharts.Add

.ChartWizardsource:=Worksheets("Sheet1").Range("A1:A20M),_

Gallcry:=xlLine,Title:="FebruaryData"

EndWith

ChartObject對象充當Chart對象的容器。CharlObject對象的屬性和方法控制工作表上嵌

入圖表的外觀和大小。ChartObjcct對象是ChartObjccts集合的成員。ChartObjccts集合包含單

一工作表上的所有嵌入圖表。

使用ChartObjects(index)(其中index是嵌入圖表的索引號或名稱)可以返回單個

ChartObject對象。

示例

以下示例設置名為“Sheeil”的工作表上嵌入圖表ChartI中的圖表區圖案。

Worksheets(nSheet1").CharlObjects(1).Chart._

ChartArea.Format.Fi11.Pattern=msoPattcrnLightDownwardDiagonal

當選定嵌入圖表時，其名稱顯示在“名稱”框中。使用Name屬性可設置或返回ChartObject

對象的名稱。以下示例對工作表“Sheell”上的嵌入圖表“Chart1”使用了圓角。

WorksheetsC'sheetI'^.ChartObjectsC'chartI").RoundedCorners=True

5,保持圖表位置居中by:Lee1892

2013-12-03

PrivateSubKeepSquare()

DimdXDiff#,dYDiff#,dDifT#

DimdXMin#.dXMax#.dYMin#,dYMax#

WithChartObjccts(1).Chart

With.Axes(xlCategory)

.MaximuinScalelsAuto=True

.MinimjinScalelsAuto=True

dXMax=.MaximumScale:dXMin=.MinimumScale

dXDiff=dXMax-dXMin

EndWith

With.Axcs(xlValuc)

.MaximuinScalelsAuto=True

.MininumScalcIsAuto=True

dYMax=.MaximumScale:dYMin=.MinimumScale

dYDiff=dYMax-dYMin

EndWith

dDiff=dXDiff

IfdXDiff<dYDiffThcndDiff=dYDiff

With.Axes(xlCategory)

.MaximumScale=dXMax+(dDiff-dXDiff)/2

.MinimjinScale=dXMin-(dDiff-dXDif'O/2

EndWith

With.Axes(xlValue)

.MaxiniumScale=dYMax+(dDiff-dYDiff)/2

.MinimjinScale=dYMin-(dDiff-dYDiff)/2

EndWith

EndWith

EndSub

6,分表，修改數據序列公式

Sublqxs()

DimShtAsWorkshee!,ShtlAsWorksheet

DimArr,i&,r%,Arrl(),ks,js,nm$

Application.Screenupdating=False

Application.DisplayAlerts=False

SetShtl=Sheets(“源表”)

Shi1.Activate

ForEachShtInSheets

IfSht.Name<>Shtl.NameThenSh(.Delete

NextSht

Arr=[alJ.CurrentRegion

Fori=3ToUBound(Arr)

IfAtr(i,l)o,,(rThen

r=r+1

RcDimPreserveArrl(lTor)

Arrl(r)=i

EndIf

Next

Fori=1Tor

Ifi<>rThen

js=Anl(i+1)-1

Else

js=UBoun(J(Arr)

EndIf

ks=Arrl(i)

Shtl.Copyafter:=Sheets(Sheets.Count)

ActiveSheet.Name=Arr(ks,I)

[a3:e500].ClearContents

Shtl.Cclls(ks,l).Rcsizc(js-ks+1,5).Copy[a3]

nm=Arr(ks,I)

ActivcShcct.ChartObjccts(1).Activate

WithActiveChart

.SetSourceDataSource:=Sheets(nm).Range(dz),PlotBy:=xlColumns

.FullSeriesCollec(ion(1).Select

Selection.Formula="=SERIES("&nm&"!R2C47'&nm&"!R3C1:R"&js-ks+3

&"C2,”&nm&”!R3c4:R"&js-ks+3&"C4J)n

.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

.FullSeriesCollec(ion(3).Delete

EndWith

Next

Application.DisplayAlerts=True

Application.ScreenUpdating=True

EndSub

7,自動制作多圖表

*9757-l-l.html

'2012-9-13

SubChartsAdd()

DimmyChartAsChartobject

DimiAsInteger

DimRAsInteger

R=Int(Sheetl.Range("A65536").End(xlUp).Row-1)/20

Fori=1ToR

SetmyChail=Sheet1.ChartObjects.Add_

(Left:=200,_

Top:=(i-1)*260+20,_

Width:=330,Height:=210)

WithmyChart.Chart

.ChartType=xlColuninClustered

.SetSourceDataSource:=Cells(20*i-18,1).Resize(20,2)

EndWith

Next

SetmyChart=Nothing

EndSub

42014-5-4

48085-l-l.html

SubChartsAdd()

DimmyChartAsChartObject

DimMyc%,i&

OnErrorResumeNext

Myc=[iv3].End(xlToLeft).Column

nin=ActiveSheel.Name

Fori=1ToMycStep8

SetmyChart=ActiveSheet.CharlObjects.Add_

(Left:=Cells(3,i).Left,_

Top:=Cells(3,i).Top,_

Width:=Cells(3,i).Resize(l,7).Width,Height:=Cells(3,i).Resize(16,l).Height)

WithmyChart.Chart

.ChartType=xlXYScatterLinesNoMarkers，散點圖

.SetSourceDataSource:=Cells(550,i+l).Resize(1351,2)

EndWith

myChart.Activate

WithActiveChart

.FullScriesCollection(1).Selcct

.FullSeriesCollection(I).XValues=&nm&"!M&Cells(55O,i+

2).Resize(1351,l).Address

.FullSeriesCollection(I).Values='r="&nm&"!"&Cells(550,i+l).Resize(l351,

1).Address

.FullSeriesCollection(1).Name="="&nm&"!"&Cells(2,i+1).Address

.SeriesCollection.NewSeries

.FullSeriesCollection(2).XValues="二"&nm&"!"&CelIs(55O,i+

6).Resize()351,1).Address

.FunSeriesCollection(2).Values=n="&nm&"!"&Cells(550,i+5).Resize(1351,

1).Address

.FullSeriesCollection(2).Name="="&nm&"!"&Cells(2,i+5).Address

.Axes(xlValue).MaximumScaIc=500

.Axes(xlValue).MinimumScale=-200

.Axes(xlValue).MajorUnit=100

.Axes(xlValue).MinorUnit=20.2

.Axes(xlCategory).MinimumScale=-0.000005

.Axes(xlCategory).MaximumScale=O.C0003

.Axcs(xlCatcgory).MajorUnit=0.000005

.Axes(xlCategory).MinorUnit=0.000001

.Legend.Position=xlBottom

.SetElement(msoElementChartTitleAboveChart)

.ChartTitle.Text=Cells(l,i).Value

.Size=14

EndWith

EndWith

Next

SetniyChart=Nothing

EndSub

8,自動生成圖表

42014-8-5

*2829-1-l.html

Sublqxs()

DimMyr&,bt$

Myr=Cells(Rows.Count,I).End(xlUp).Row

ActivcShcct.ChartObjccts.AddLcft:=[g3].Lcft,_

Top:=[g31.Top,_

Width:=[g3].Resize(1,7).Width,Height:=[g3].Resize(16,1).Height

AcliveSheet.ChartObjects(1).Activate

WithActiveChart

.ChartType=x1XYScatlerSmoothNoMarkers

.SetSourceDataSource:=Slieets("CHART").Range("A3:B"&Myr),PlotBy_

:=xlColumns

.SeriesCollection.NewSeries

.ScricsCollcction(1).XValues="=CHART!R3C4:R"&Myr&℃4"

.SeriesCollection(l).Values="=CHART!R3C2:R"&Myr&"C2"

.SeriesCollection(l).Name="=CHART!R2C2"

.SeriesColleclion(2).XValues="=CHART!R3C4:R"&Myr&”C4”

.SeriesColIection(2).Values="=CHART!R3C1:R"&Myr&"Cl"

.SeriesCollection(2).Name="=CHART!R2Cr'

.ChartTitlc.Charactcrs.Tcxt=bt

.Axes(xlCategory,xlPrimary).HasTitle=True

.Axes(xlValue,xlPrimary).HasTide=True

.Axes(xlValue).MajorUnit=I

.ChcutTitlc.Select

WithSelection.Font

.FontStyle="加粗”

.Size=18

EndWith

.PIotArea.Select

WithSelection.Border

.Weight=xlThin

.LineStyle=xlNone

EndWith

Selection.Intcrior.Colorlndcx=xlNone

EndWith

Range("al").Select

EndSub

9,自動制作多圖表.

*2014-9-28

'5286-1-1.html

Sublqxs()

DimniyChartAsChartObject,Arr,i&,mx,mn.If

Arr=1alj.CurrcntRcgion

Fori=1ToUBound(Arr,2)

If=Cclls(l,UBound(Arr,2)+2).Lcft

mx=Application.Max(Cells(1,i).Resize(UBoundiArr),1))

mn=Application.Min(Cells(1,i).Resize(UBound(Arr),1))

SetmyChart=ActiveSheet.ChartObjects.Add_

(Left:=lf,Top:=(i-l)*220+10,_

Width:=450,Height:=210)

WithmyCharl.Charl

.ChartType=xlLine，折線圖

.SeiSourceDataSource:=Cells(I,i).Resize(UBound(Arr),I),_

PlotBy:=xlCokimns

.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,根據指定級別自動制作多圖表

42015-4-23

42019-l-l.html

PrivateSubWorksheet_Change(ByValTargetAsRange)

IfTarget.Address<>H$OS1"ThenExitSub

DimArr,i&,m&,j&

Dimd,k,t,tt,ks,js,aa,c1%,c2%,c3%

Setd=CreateObjectC'Scripting.Dictionary")

Arr=[al].CurrcntRegion

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)

in=Application.Match(Targct.Value,k,0)+1

t=Left(t,Len(t)-1)

IfInStr(t,'V)Then

aa=Splits

ks=aa(0):js=aa(UBound(aa))

Forj=2To6

ActiveSheet.ChartObjects("圖表"&j).Activate

SelectCasej

Case2

cl=4:c2=5:c3=6

Case3

cl=6:c2=7:c3=8

Case4

cl=6:c2=7:c3=9

Case5

cl=6:c2=7:c3=10