ExcelVBA批量自动制图表实例集锦.docx

ExcelVBA批量自动制图表实例集锦.docx

《ExcelVBA批量自动制图表实例集锦.docx》由会员分享，可在线阅读，更多相关《ExcelVBA批量自动制图表实例集锦.docx（14页珍藏版）》请在冰豆网上搜索。

ExcelVBA批量自动制图表实例集锦

1,自动生成图表

-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.Nameyy=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

=yy&"月份合格率"

EndWith

ActiveSheet.ChartObjects（nm2）.Activate

WithActiveChart

.ChartArea.Selectdz="H2:

T2,H"&js+1&":

T"&js+1

.SetSourceDataSource:

=Sheets（nm）.Range（dz）,PlotBy:

=xlRowsdz2="R"&js+1&"C8:

R"&js+1&"C20".SeriesCollection

（1）.Values="='"&nm&"'!

"&dz2.ChartTitle.Select

=yy&"月份不良趋势统计EndWith

Range（"A"&ks）.Select

Application.ScreenUpdating=True

MsgBox"OK"

EndSub

8月粉不良趋势统计

2,批量插入图表

‘2010-9-27

‘批量绘图表.xls

SubChartsAdd（）

DimmyChartAsChartObject

DimiAsInteger

DimRAsInteger

DimmAsInteger

R=Sheet1.Range（"A65536"）.End（xlUp）.Row-1

m=Abs（Int（-（R/4）））

Fori=1ToR

SetmyChart=_

（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.=10

EndWith

.HasLegend=False

With.ChartTitle

.Left=5

.Top=1

.Font.Size=14

.Font.Name="华文行楷"EndWithWith.PlotArea.Interior

.ColorIndex=2

.PatternColorIndex=1.Pattern=xlSolidEndWith.Axes（xlCategory）.=10.Axes（xlValue）.=10

EndWith

Next

Sheet2.Select

SetmyChart=Nothing

EndSub

3,批量插入图表

‘2013-9-30

‘#pid7221588

SubOpenFiles（）

DimmyXAsRange

DimmyYAsRange

Dimi%,j&

Application.ScreenUpdating=False

ActiveSheet.ChartObjects（"图表1"）.Activate

Fori=1To‘序列集合对象的用法

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+1Step2j=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对象。

示例

以下示例设置名为"Sheetl”的工作表上嵌入图表Chart1中的图表区图案。

Worksheets（"Sheet1"）.ChartObjects

（1）.Chart._

=msoPatternLightDownwardDiagonal

当选定嵌入图表时，其名称显示在“名称”框中。

使用Name属性可设置或返回ChartObject对象的名称。

以下示例对工作表“Sheetl”上的嵌入图表“Chart1”使用了圆角。

Worksheets（"sheet1"）.ChartObjects（"chart1"）.RoundedCorners=True

5,保持图表位置居中by:

Lee1892

‘201-312-03

PrivateSubKeepSquare（）

DimdXDiff#,dYDiff#,dDiff#

DimdXMin#,dXMax#,dYMin#,dYMax#

WithChartObjects

（1）.Chart

With.Axes（xlCategory）.MaximumScaleIsAuto=True.MinimumScaleIsAuto=TruedXMax=.MaximumScale:

dXMin=.MinimumScaledXDiff=dXMax-dXMin

EndWith

With.Axes（xlValue）.MaximumScaleIsAuto=True.MinimumScaleIsAuto=TruedYMax=.MaximumScale:

dYMin=.MinimumScaledYDiff=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,分表，修改数据序列公式

‘-1100811-1-1.html

Sublqxs（）

DimShtAsWorksheet,Sht1AsWorksheet

DimArr,i&,r%,Arr1（）,ks,js,nm$

Application.ScreenUpdating=FalseApplication.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+1ReDimPreserveArr1（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,自动制作多图表

-919757-1-1.html

‘2012-9-13

SubChartsAdd（）

DimmyChartAsChartObject

DimiAsInteger

DimRAsInteger

R=Int（Sheet1.Range（"A65536"）.End（xlUp）.Row-1）/20

Fori=1ToR

SetmyChart=_

（Left:

=200,_

Top:

=（i-1）*260+20,_

Width:

=330,Height:

=210）

WithmyChart.Chart

.ChartType=xlColumnClustered

.SetSourceDataSource:

=Cells（20*i-18,1）.Resize（20,2）EndWith

Next

SetmyChart=Nothing

EndSub

‘2014-5-4

‘-1118085-1-1.html

SubChartsAdd（）

DimmyChartAsChartObject

DimMyc%,i&

OnErrorResumeNext

Myc=[iv3].End（xlToLeft）.Column

nm=ActiveSheet.Name

Fori=1ToMycStep8

SetmyChart=_

（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,i2）.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,i6）.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）.ValueWith.

.Size=14

EndWith

EndWith

Next

SetmyChart=Nothing

EndSub

8,自动生成图表

‘2014-8-5‘-1142829-1-1.html

Sublqxs（）

DimMyr&,bt$

Myr=Cells（Rows.Count,1）.End（xlUp）.Row

Left:

=[g3].Left,_

Top:

=[g3].Top,_

Width:

=[g3].Resize（1,7）.Width,Height:

=[g3].Resize（16,1）.HeightActiveSheet.ChartObjects

（1）.ActivateWithActiveChart

.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=.=bt.Axes（xlCategory,xlPrimary）.HasTitle=True.Axes（xlCategory,xlPrimary）.=.Axes（xlValue,xlPrimary）.HasTitle=True.Axes（xlValue,xlPrimary）.=.Axes（xlValue）.MajorUnit=1.ChartTitle.SelectWithSelection.Font

.FontStyle="加粗"

.Size=18

EndWith

.PlotArea.Select

WithSelection.Border

.Weight=xlThin

.LineStyle=xlNone

EndWith

=xlNone

EndWith

Range（"a1"）.Select

EndSub

9,自动制作多图表

‘2014-9-28

‘-1155286-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=_

（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

‘-342019-1-1.html

PrivateSubWorksheet_Change（ByValTargetAsRange）

IfTarget.Address<>"$O$1"ThenExitSub

DimArr,i