|
看看下面的代码：
Sub InsertCharts()
Dim sh As Worksheet, chObj As ChartObject, chtRng As Range, NewSer As Series
Dim chtTitle As Range, SerX As Range, SerY As Range
'关闭屏幕刷新
Application.ScreenUpdating = False
'设置sh为Sheet1
Set sh = Worksheets("Sheet1")
'删除Sheet1已有的所有图表(如果有的话)
If sh.ChartObjects.Count > 0 Then sh.ChartObjects.Delete
'设置第1个图表标题的引用区域
Set chtTitle = sh.Range("A1")
'下面进行循环
Do
'设置图表第1个系列线的X和Y值引用区域
Set SerX = chtTitle.Offset(1, 0).Resize(chtTitle.Offset(0, 1), 1)
Set SerY = SerX.Offset(0, 1)
'设置图表的放置区域
Set chtRng = chtTitle.Offset(0, 4).Resize(10, 6)
'插入一个空的内嵌的图表在chtRng区域用Add(左边位置,顶部位置,宽度,高度)
Set chObj = sh.ChartObjects.Add(chtRng.Left, chtRng.Top, chtRng.Width, chtRng.Height)
With chObj.Chart
'设置图表类型为XY折线散点图
.ChartType = xlXYScatterLines
'给图表添加一个新系列
Set NewSer = .SeriesCollection.NewSeries
With NewSer
.XValues = SerX '设置X值引用
.Values = SerY '设置Y值引用
.Name = "挖槽" '设置系列名称用于图例
End With
'设置第2个系列的X和Y值引用区域
Set SerX = chtTitle.Offset(1, 2).Resize(chtTitle.Offset(0, 3), 1)
Set SerY = SerX.Offset(0, 1)
'给图表添加第2个系列
Set NewSer = .SeriesCollection.NewSeries
With NewSer
.XValues = SerX '设置X值引用
.Values = SerY '设置Y值引用
.Name = "天然" '设置系列名称用于图例
End With
'设置图表标题
.HasTitle = True
.ChartTitle.Caption = chtTitle
'设置图例放置位置在底部
.HasLegend = True
.Legend.Position = xlLegendPositionBottom
End With
'设置下一个图表的标题引用单元格
Set chtTitle = chtTitle.Offset(1 + chtTitle.Offset(0, 1), 0)
'当下一个chtTitle引用单元格有效时循环
Loop While chtTitle Like "c.s*"
MsgBox "完成任务了！" & vbCrLf & "您达到了目的，" & vbCrLf & _
"别忘了要到club.excelhome.net解答别人的问题。" & vbCrLf & vbCrLf & _
"chenjun" & vbCrLf & _
Format(Now, "yyyy.mm.dd h:mm:ss")
'释放所有的对象变量
Set sh = Nothing
Set chObj = Nothing
Set chtRng = Nothing
Set NewSer = Nothing
Set chtTitle = Nothing
Set SerX = Nothing
Set SerY = Nothing
'打开屏幕刷新
Application.ScreenUpdating = True
End Sub
[此贴子已经被作者于2005-1-11 0:29:26编辑过] | 
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2004-12-28 15:57
![[原创]画图](https://files-c.excelhome.net/forum/dvbbs/2004-12/20041228155534287.jpg "[原创]画图")
楼主