Chart Export - 1. 将Excel中的图表导出成gif格式的图片保存到硬盘上
Sub ExportChart() Dim myChart As Chart Set myChart = ActiveChart myChart.Export Filename:="C:\Chart.gif", Filtername:="GIF" End Sub 理论上图表可以被保存成任何类型的图片文件,读者可以自己去尝试。 - 2. 将Excel中的图表导出成可交互的页面保存到硬盘上
Sub SaveChartWeb() ActiveWorkbook.PublishObjects.Add _ SourceType:=xlSourceChart, _ Filename:=ActiveWorkbook.Path & "\Sample2.htm", _ Sheet:=ActiveSheet.name, _ Source:=" Chart 1", _ HtmlType:=xlHtmlChart
ActiveWorkbook.PublishObjects(1).Publish (True) End Sub
返回目录
Chart Format - 1. 操作Chart对象。给几个用VBA操作Excel Chart对象的例子,读者可以自己去尝试一下。
Public Sub ChartInterior() Dim myChart As Chart 'Reference embedded chart Set myChart = ActiveSheet.ChartObjects(1).Chart With myChart 'Alter interior colors of chart components .ChartArea.Interior.Color = RGB(1, 2, 3) .PlotArea.Interior.Color = RGB(11, 12, 1) .Legend.Interior.Color = RGB(31, 32, 33) If .HasTitle Then .ChartTitle.Interior.Color = RGB(41, 42, 43) End If End With End Sub
Public Sub SetXAxis() Dim myAxis As Axis Set myAxis = ActiveSheet.ChartObjects(1).Chart.Axes(xlCategory, xlPrimary) With myAxis 'Set properties of x-axis .HasMajorGridlines = True .HasTitle = True .AxisTitle.Text = "My Axis" .AxisTitle.Font.Color = RGB(1, 2, 3) .CategoryNames = Range("C2:C11") .TickLabels.Font.Color = RGB(11, 12, 13) End With End Sub
Public Sub TestSeries() Dim mySeries As Series Dim seriesCol As SeriesCollection Dim I As Integer I = 1 Set seriesCol = ActiveSheet.ChartObjects(1).Chart.SeriesCollection For Each mySeries In seriesCol Set mySeries = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(I) With mySeries .MarkerBackgroundColor = RGB(1, 32, 43) .MarkerForegroundColor = RGB(11, 32, 43) .Border.Color = RGB(11, 12, 23) End With I = I + 1 Next End Sub
Public Sub TestPoint() Dim myPoint As Point Set myPoint = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1).Points(3) With myPoint .ApplyDataLabels xlDataLabelsShowValue .MarkerBackgroundColor = RGB(1, 2, 3) .MarkerForegroundColor = RGB(11, 22, 33) End With End Sub
Sub chartAxis() Dim myChartObject As ChartObject Set myChartObject = ActiveSheet.ChartObjects.Add(Left:=200, Top:=200, _ Width:=400, Height:=300) myChartObject.Chart.SetSourceData Source:= _ ActiveWorkbook.Sheets("Chart Data").Range("A1:E5") myChartObject.SeriesCollection.Add Source:=ActiveSheet.Range("C4:K4"), Rowcol:=xlRows myChartObject.SeriesCollection.NewSeries myChartObject.HasTitle = True With myChartObject.Axes(Type:=xlCategory, AxisGroup:=xlPrimary) .HasTitle = True .AxisTitle.Text = "Years" .AxisTitle.Font.Name = "Times New Roman" .AxisTitle.Font.Size = 12 .HasMajorGridlines = True .HasMinorGridlines = False End With End Sub
Sub FormattingCharts() Dim myChart As Chart Dim ws As Worksheet Dim ax As Axis
Set ws = ThisWorkbook.Worksheets("Sheet1") Set myChart = GetChartByCaption(ws, "GDP")
If Not myChart Is Nothing Then Set ax = myChart.Axes(xlCategory) With ax .AxisTitle.Font.Size = 12 .AxisTitle.Font.Color = vbRed End With Set ax = myChart.Axes(xlValue) With ax .HasMinorGridlines = True .MinorGridlines.Border.LineStyle = xlDashDot End With With myChart.PlotArea .Border.LineStyle = xlDash .Border.Color = vbRed .Interior.Color = vbWhite .Width = myChart.PlotArea.Width + 10 .Height = myChart.PlotArea.Height + 10 End With myChart.ChartArea.Interior.Color = vbWhite myChart.Legend.Position = xlLegendPositionBottom End If
Set ax = Nothing Set myChart = Nothing Set ws = Nothing End Sub Function GetChartByCaption(ws As Worksheet, sCaption As String) As Chart Dim myChart As ChartObject Dim myChart As Chart Dim sTitle As String
Set myChart = Nothing For Each myChart In ws.ChartObjects If myChart.Chart.HasTitle Then sTitle = myChart.Chart.ChartTitle.Caption If StrComp(sTitle, sCaption, vbTextCompare) = 0 Then Set myChart = myChart.Chart Exit For End If End If Next Set GetChartByCaption = myChart Set myChart = Nothing Set myChart = Nothing End Function - 2. 使用VBA在Excel中添加图表
Public Sub AddChartSheet() Dim aChart As Chart
Set aChart = Charts.Add With aChart .Name = "Mangoes" .ChartType = xlColumnClustered .SetSourceData Source:=Sheets("Sheet1").Range("A3:D7"), PlotBy:=xlRows .HasTitle = True .ChartTitle.Text = "=Sheet1!R3C1" End With End Sub - 3. 遍历并更改Chart对象中的图表类型
Sub ChartType() Dim myChart As ChartObject For Each myChart In ActiveSheet.ChartObjects myChart.Chart.Type = xlArea Next myChart End Sub - 4. 遍历并更改Chart对象中的Legend
Sub LegendMod() Dim myChart As ChartObject For Each myChart In ActiveSheet.ChartObjects With myChart.Chart.Legend.font .name = "Calibri" .FontStyle = "Bold" .Size = 12 End With Next myChart End Sub - 5. 一个格式化Chart的例子
Sub ChartMods() ActiveChart.Type = xlArea ActiveChart.ChartArea.font.name = "Calibri" ActiveChart.ChartArea.font.FontStyle = "Regular" ActiveChart.ChartArea.font.Size = 9 ActiveChart.PlotArea.Interior.ColorIndex = xlNone ActiveChart.Axes(xlValue).TickLabels.font.bold = True ActiveChart.Axes(xlCategory).TickLabels.font.bold = True ActiveChart.Legend.Position = xlBottom End Sub - 6. 通过VBA更改Chart的Title
Sub ApplyTexture() Dim myChart As Chart Dim ser As Series Set myChart = ActiveChart Set ser = myChart.SeriesCollection(2) ser.Format.Fill.PresetTextured (msoTextureGreenMarble) End Sub - 7. 在VBA中使用自定义图片填充Chart对象的series区域
Sub FormatWithPicture() Dim myChart As Chart Dim ser As Series Set myChart = ActiveChart Set ser = myChart.SeriesCollection(1) MyPic = "C:\Title.jpg" ser.Format.Fill.UserPicture (MyPic) End Sub Excel中的Chart允许用户对其中选定的区域自定义样式,其中包括使用图片选中样式。在Excel的Layout菜单下有一个Format Selection,首先在Chart对象中选定要格式化的区域,例如series,然后选择该菜单,在弹出的对话框中即可对所选的区域进行格式化。如series选项、填充样式、边框颜色和样式、阴影以及3D效果等。下面再给出一个在VBA中使用渐变色填充Chart对象的series区域的例子。Sub TwoColorGradient() Dim myChart As Chart Dim ser As Series Set myChart = ActiveChart Set ser = myChart.SeriesCollection(1) MyPic = "C:\Title1.jpg" ser.Format.Fill.TwoColorGradient msoGradientFromCorner, 3 ser.Format.Fill.ForeColor.ObjectThemeColor = msoThemeColorAccent6 ser.Format.Fill.BackColor.ObjectThemeColor = msoThemeColorAccent2 End Sub - 8. 通过VBA格式化Chart对象中series的趋势线样式
Sub FormatLineOrBorders() Dim myChart As Chart Set myChart = ActiveChart With myChart.SeriesCollection(1).Trendlines(1).Format.Line .DashStyle = msoLineLongDashDotDot .ForeColor.RGB = RGB(50, 0, 128) .BeginArrowheadLength = msoArrowheadShort .BeginArrowheadStyle = msoArrowheadOval .BeginArrowheadWidth = msoArrowheadNarrow .EndArrowheadLength = msoArrowheadLong .EndArrowheadStyle = msoArrowheadTriangle .EndArrowheadWidth = msoArrowheadWide End With End Sub Excel允许用户为Chart对象的series添加趋势线(trendline),首先在Chart中选中要设置的series,然后选择Layout菜单下的trendline,选择一种trendline样式。 - 9. 一组利用VBA格式化Chart对象的例子
Sub FormatBorder() Dim myChart As Chart Set myChart = ActiveChart With myChart.ChartArea.Format.Line .DashStyle = msoLineLongDashDotDot .ForeColor.RGB = RGB(50, 0, 128) End With End Sub
Sub AddGlowToTitle() Dim myChart As Chart Set myChart = ActiveChart myChart.ChartTitle.Format.Line.ForeColor.RGB = RGB(255, 255, 255) myChart.ChartTitle.Format.Line.DashStyle = msoLineSolid myChart.ChartTitle.Format.Glow.Color.ObjectThemeColor = msoThemeColorAccent6 myChart.ChartTitle.Format.Glow.Radius = 8 End Sub
Sub FormatShadow() Dim myChart As Chart Set myChart = ActiveChart With myChart.Legend.Format.Shadow .ForeColor.RGB = RGB(0, 0, 128) .OffsetX = 5 .OffsetY = -3 .Transparency = 0.5 .Visible = True End With End Sub
Sub FormatSoftEdgesWithLoop() Dim myChart As Chart Dim ser As Series Set myChart = ActiveChart Set ser = myChart.SeriesCollection(1) For i = 1 To 6 ser.Points(i).Format.SoftEdge.Type = i Next i End Sub - 10. 在VBA中对Chart对象应用3D效果
Sub Assign3DPreset() Dim myChart As Chart Dim shp As Shape Set myChart = ActiveChart Set shp = myChart.Shapes(1) shp.ThreeD.SetPresetCamera msoCameraIsometricLeftDown End Sub
Sub AssignBevel() Dim myChart As Chart Dim ser As Series Set myChart = ActiveChart Set ser = myChart.SeriesCollection(1) ser.Format.ThreeD.Visible = True ser.Format.ThreeD.BevelTopType = msoBevelCircle ser.Format.ThreeD.BevelTopInset = 16 ser.Format.ThreeD.BevelTopDepth = 6 End Sub
返回目录
Chart Lengend - 1. 设置Lengend的位置和ChartArea的颜色
Sub FormattingCharts() Dim myChart As Chart Dim ws As Worksheet Dim ax As Axis
Set ws = ThisWorkbook.Worksheets("Sheet1") Set myChart = GetChartByCaption(ws, "GDP")
If Not myChart Is Nothing Then myChart.ChartArea.Interior.Color = vbWhite myChart.Legend.Position = xlLegendPositionBottom End If
Set ax = Nothing Set myChart = Nothing Set ws = Nothing End Sub Function GetChartByCaption(ws As Worksheet, sCaption As String) As Chart Dim myChart As ChartObject Dim myChart As Chart Dim sTitle As String
Set myChart = Nothing For Each myChart In ws.ChartObjects If myChart.Chart.HasTitle Then sTitle = myChart.Chart.ChartTitle.Caption If StrComp(sTitle, sCaption, vbTextCompare) = 0 Then Set myChart = myChart.Chart Exit For End If End If Next Set GetChartByCaption = myChart Set myChart = Nothing Set myChart = Nothing End Function - 2. 通过VBA给Chart添加Lengend
Sub legend() Dim myChartObject As ChartObject Set myChartObject = ActiveSheet.ChartObjects.Add(Left:=200, Top:=200, _ Width:=400, Height:=300) myChartObject.Chart.SetSourceData Source:= _ ActiveWorkbook.Sheets("Chart Data").Range("A1:E5") myChartObject.SeriesCollection.Add Source:=ActiveSheet.Range("C4:K4"), Rowcol:=xlRows myChartObject.SeriesCollection.NewSeries With myChartObject.Legend .HasLegend = True .Font.Size = 16 .Font.Name = "Arial" End With End Sub
返回目录
Chart Protect - 1. 保护图表
Sub ProtectChart() Dim myChart As Chart Set myChart = ThisWorkbook.Sheets("Protected Chart") myChart.Protect "123456", True, True, , True myChart.ProtectData = False myChart.ProtectGoalSeek = True myChart.ProtectSelection = True End Sub Excel中的Chart可以和Sheet一样被保护,读者可以选中图表所在的Tab,然后通过Review菜单下的Protect Sheet菜单来对图表进行保护设置。代码中的Protected Chart123456是设置保护时的密码,有关Protect函数的参数和设置保护时的其它属性读者可以查阅Excel自带的帮助文档。 - 2. 取消图表保护
Sub UnprotectChart() Dim myChart As Chart Set myChart = ThisWorkbook.Sheets("Protected Chart") myChart.Unprotect "123456" myChart.ProtectData = False myChart.ProtectGoalSeek = False myChart.ProtectSelection = False End Sub 与保护图表的示例相对应,可以通过VBA撤销对图表的保护设置。
返回目录
Chart Title - 1. 通过VBA添加图表的标题
Sub chartTitle() Dim myChartObject As ChartObject Set myChartObject = ActiveSheet.ChartObjects.Add(Left:=200, Top:=200, _ Width:=400, Height:=300) myChartObject.Chart.SetSourceData Source:= _ ActiveWorkbook.Sheets("Chart Data").Range("A1:E5") myChartObject.SeriesCollection.Add Source:=ActiveSheet.Range("C4:K4"), Rowcol:=xlRows myChartObject.SeriesCollection.NewSeries myChartObject.HasTitle = True End Sub 如果要设置标题显示的位置,可以在上述代码的后面加上: With myChartObject.ChartTitle .Top = 100 .Left = 150 End With 如果要同时设置标题字体,可以在上述代码的后面加上: myChartObject.ChartTitle.Font.Name = "Times" - 2. 通过VBA修改图表的标题
Sub charTitleText() ActiveChart.ChartTitle.Text = "Industrial Disease in North Dakota" End Sub - 3. 一个通过标题搜索图表的例子
Function GetChartByCaption(ws As Worksheet, sCaption As String) As Chart Dim myChart As ChartObject Dim myChart As Chart Dim sTitle As String
Set myChart = Nothing For Each myChart In ws.ChartObjects If myChart.Chart.HasTitle Then sTitle = myChart.Chart.ChartTitle.Caption If StrComp(sTitle, sCaption, vbTextCompare) = 0 Then Set myChart = myChart.Chart Exit For End If End If Next Set GetChartByCaption = myChart Set myChart = Nothing Set myChart = Nothing End Function Sub TestGetChartByCaption() Dim myChart As Chart Dim ws As Worksheet Set ws = ThisWorkbook.Worksheets("Sheet1") Set myChart = GetChartByCaption(ws, "I am the Chart Title")
If Not myChart Is Nothing Then Debug.Print "Found chart" Else Debug.Print "Sorry - chart not found" End If
Set ws = Nothing Set myChart = Nothing End Sub
返回目录
Chart - 1. 通过VBA创建Chart的几种方式
使用ChartWizard方法创建Sub CreateExampleChartVersionI() Dim ws As Worksheet Dim rgChartData As Range Dim myChart As Chart
Set ws = ThisWorkbook.Worksheets("Sheet1") Set rgChartData = ws.Range("B1").CurrentRegion Set myChart = Charts.Add Set myChart = myChart.Location(xlLocationAsObject, ws.Name) With myChart .ChartWizard _ Source:=rgChartData, _ Gallery:=xlColumn, _ Format:=1, _ PlotBy:=xlColumns, _ CategoryLabels:=1, _ SeriesLabels:=1, _ HasLegend:=True, _ Title:="Version I", _ CategoryTitle:="Year", _ ValueTitle:="GDP in billions of $" End With
Set myChart = Nothing Set rgChartData = Nothing Set ws = Nothing End Sub 使用Chart Object方法创建Sub CreateExampleChartVersionII() Dim ws As Worksheet Dim rgChartData As Range Dim myChart As Chart
Set ws = ThisWorkbook.Worksheets("Basic Chart") Set rgChartData = ws.Range("B1").CurrentRegion Set myChart = Charts.Add Set myChart = myChart.Location(xlLocationAsObject, ws.Name)
With myChart .SetSourceData rgChartData, xlColumns .HasTitle = True .ChartTitle.Caption = "Version II" .ChartType = xlColumnClustered
With .Axes(xlCategory) .HasTitle = True .AxisTitle.Caption = "Year" End With
With .Axes(xlValue) .HasTitle = True .AxisTitle.Caption = "GDP in billions of $" End With
End With
Set myChart = Nothing Set rgChartData = Nothing Set ws = Nothing End Sub 使用ActiveWorkbook.Sheets.Add方法创建Sub chart() Dim myChartSheet As Chart Set myChartSheet = ActiveWorkbook.Sheets.Add _ (After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count), _ Type:=xlChart) End Sub 使用ActiveSheet.ChartObjects.Add方法创建Sub charObj() Dim myChartObject As ChartObject Set myChartObject = ActiveSheet.ChartObjects.Add(Left:=200, Top:=200, _ Width:=400, Height:=300) myChartObject.Chart.SetSourceData Source:= _ ActiveWorkbook.Sheets("Chart Data").Range("A1:E5") End Sub 不同的创建方法可以应用在不同的场合,如Sheet中内嵌的图表,一个独立的Chart Tab等,读者可以自己研究。最后一种方法的末尾给新创建的图表设定了数据源,这样图表就可以显示出具体的图形了。 如果需要指定图表的类型,可以加上这句代码: myChartObject.ChartType = xlColumnStacked 如果需要在现有图表的基础上添加新的series,下面这行代码可以参考: myChartObject.SeriesCollection.Add Source:=ActiveSheet.Range("C4:K4"), Rowcol:=xlRows 或者通过下面这行代码对已有的series进行扩展: myChartObject.SeriesCollection.Extend Source:=Worksheets("Chart Data").Range("P3:P8") - 2. 一个相对完整的通过VBA创建Chart的例子
'Common Excel Chart Types '------------------------------------------------------------------- 'Chart | VBA Constant (ChartType property of Chart object) | '================================================================== 'Column | xlColumnClustered, xlColumnStacked, xlColumnStacked100| 'Bar | xlBarClustered, xlBarStacked, xlBarStacked100 | 'Line | xlLine, xlLineMarkersStacked, xlLineStacked | 'Pie | xlPie, xlPieOfPie | 'Scatter | xlXYScatter, xlXYScatterLines | '-------------------------------------------------------------------
Public Sub AddChartSheet() Dim dataRange As Range Set dataRange = ActiveWindow.Selection Charts.Add 'Create a chart sheet With ActiveChart 'Set chart properties .ChartType = xlColumnClustered .HasLegend = True .Legend.Position = xlRight
.Axes(xlCategory).MinorTickMark = xlOutside .Axes(xlValue).MinorTickMark = xlOutside .Axes(xlValue).MaximumScale = _ Application.WorksheetFunction.RoundUp( _ Application.WorksheetFunction.Max(dataRange), -1) .Axes(xlCategory).HasTitle = True .Axes(xlCategory).AxisTitle.Characters.Text = "X-axis Labels" .Axes(xlValue).HasTitle = True .Axes(xlValue).AxisTitle.Characters.Text = "Y-axis"
.SeriesCollection(1).name = "Sample Data" .SeriesCollection(1).Values = dataRange End With End Sub - 3. 通过选取的Cells Range的值设置Chart中数据标签的内容
Sub DataLabelsFromRange() Dim DLRange As range Dim myChart As Chart Dim i As Integer Set myChart = ActiveSheet.ChartObjects(1).Chart On Error Resume Next Set DLRange = Application.InputBox _ (prompt:="Range for data labels?", Type:=8) If DLRange Is Nothing Then Exit Sub On Error GoTo 0 myChart.SeriesCollection(1).ApplyDataLabels Type:=xlDataLabelsShowValue, AutoText:=True, LegendKey:=False Pts = myChart.SeriesCollection(1).Points.Count For i = 1 To Pts myChart.SeriesCollection(1). _ Points(i).DataLabel.Characters.Text = DLRange(i) Next i End Sub 考虑下面这个场景,当采用下表的数据生成图表Chart4时,默认的效果如下图。
可以手动给该图表添加Data Labels,方法是选中任意的series,右键选择Add Data Labels。如果想要为所有的series添加Data Labels,则需要依次选择不同的series,然后重复该操作。 Excel中可以通过VBA将指定Cells Range中的值设置到Chart的Data Labels中,上面的代码就是一个例子。程序执行的时候会首先弹出一个提示框,要求用户通过鼠标去选择一个单元格区域以获取到Cells集合(或者直接输入地址),如下图: 注意VBA中输入型对话框Application.InputBox的使用。在循环中将Range中的值添加到Chart的Data Labels中。 - 4. 一个使用VBA给Chart添加Data Labels的例子
Sub AddDataLabels() Dim seSales As Series Dim pts As Points Dim pt As Point Dim rngLabels As range Dim iPointIndex As Integer
Set rngLabels = range("B4:G4")
Set seSales = ActiveSheet.ChartObjects(1).Chart.SeriesCollection(1) seSales.HasDataLabels = True
Set pts = seSales.Points
For Each pt In pts iPointIndex = iPointIndex + 1 pt.DataLabel.text = rngLabels.cells(iPointIndex).text pt.DataLabel.font.bold = True pt.DataLabel.Position = xlLabelPositionAbove Next pt End Sub
|