VBA在Excel中的应用(三)
目录
Chart Export
Chart Format
Chart Lengend
Chart Protect
Chart Title
Chart
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()Excel中的Chart允许用户对其中选定的区域自定义样式,其中包括使用图片选中样式。在Excel的Layout菜单下有一个Format Selection,首先在Chart对象中选定要格式化的区域,例如series,然后选择该菜单,在弹出的对话框中即可对所选的区域进行格式化。如series选项、填充样式、边框颜色和样式、阴影以及3D效果等。下面再给出一个在VBA中使用渐变色填充Chart对象的series区域的例子。
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 SubSub 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()Excel允许用户为Chart对象的series添加趋势线(trendline),首先在Chart中选中要设置的series,然后选择Layout菜单下的trendline,选择一种trendline样式。
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 - 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()Excel中的Chart可以和Sheet一样被保护,读者可以选中图表所在的Tab,然后通过Review菜单下的Protect Sheet菜单来对图表进行保护设置。代码中的Protected Chart123456是设置保护时的密码,有关Protect函数的参数和设置保护时的其它属性读者可以查阅Excel自带的帮助文档。
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 - 2. 取消图表保护
Sub UnprotectChart()与保护图表的示例相对应,可以通过VBA撤销对图表的保护设置。
Dim myChart As Chart
Set myChart = ThisWorkbook.Sheets("Protected Chart")
myChart.Unprotect "123456"
myChart.ProtectData = False
myChart.ProtectGoalSeek = False
myChart.ProtectSelection = False
End Sub
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()使用Chart Object方法创建
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 SubSub CreateExampleChartVersionII()使用ActiveWorkbook.Sheets.Add方法创建
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 SubSub chart()使用ActiveSheet.ChartObjects.Add方法创建
Dim myChartSheet As Chart
Set myChartSheet = ActiveWorkbook.Sheets.Add _
(After:=ActiveWorkbook.Sheets(ActiveWorkbook.Sheets.Count), _
Type:=xlChart)
End SubSub charObj()不同的创建方法可以应用在不同的场合,如Sheet中内嵌的图表,一个独立的Chart Tab等,读者可以自己研究。最后一种方法的末尾给新创建的图表设定了数据源,这样图表就可以显示出具体的图形了。
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
如果需要指定图表的类型,可以加上这句代码:
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()考虑下面这个场景,当采用下表的数据生成图表Chart4时,默认的效果如下图。
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
可以手动给该图表添加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