10.1.1 为我们的世界着色
代码清单10.1:颜色的乐趣
代码
'
代码清单10.1: 颜色的乐趣
Sub ColorWorksheet()
Dim ws As Worksheet
Dim lRow As Long
Dim lColumn As Long
Dim lColor As Long
Set ws = ThisWorkbook.Worksheets( 1 )
lRow = 1
lColumn = 1
Application.ScreenUpdating = False
Application.StatusBar = " On column " & lColumn
' 256 * 256 * 256 - 1
For lColor = 0 To 256 * 256 * 256 - 1
' record color
ws.Cells(lRow, lColumn).Interior.Color = lColor
' move to next cell
lRow = lRow + 1
' worksheet has 65,536 rows
If lRow > 256 * 256 Then
lRow = 1
lColumn = lColumn + 1
Application.StatusBar = " On column " & lColumn
End If
Next
Set ws = Nothing
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
Sub ColorWorksheet()
Dim ws As Worksheet
Dim lRow As Long
Dim lColumn As Long
Dim lColor As Long
Set ws = ThisWorkbook.Worksheets( 1 )
lRow = 1
lColumn = 1
Application.ScreenUpdating = False
Application.StatusBar = " On column " & lColumn
' 256 * 256 * 256 - 1
For lColor = 0 To 256 * 256 * 256 - 1
' record color
ws.Cells(lRow, lColumn).Interior.Color = lColor
' move to next cell
lRow = lRow + 1
' worksheet has 65,536 rows
If lRow > 256 * 256 Then
lRow = 1
lColumn = lColumn + 1
Application.StatusBar = " On column " & lColumn
End If
Next
Set ws = Nothing
Application.ScreenUpdating = True
Application.StatusBar = False
End Sub
10.1.2 字体的细微之处
代码清单10.2:Font对象—一个简单、直观的对象
代码
'
代码清单10.2: Font对象-一个简单、直观的对象
Sub DemonstrateFontObject()
Dim nColumn As Long
Dim nRow As Long
Dim avFonts As Variant
Dim avColors As Variant
For nColumn = 1 To 5
With ThisWorkbook.Worksheets( 1 ).Columns(nColumn).Font
.Size = nColumn + 10
If nColumn Mod 2 = 0 Then
.Bold = True
.Italic = False
Else
.Bold = False
.Italic = True
End If
End With
Next
avFonts = Array ( " Tahoma " , " Arial " , " MS Sans Serif " , " Verdana " , " Georgia " )
avColors = Array (vbRed, vbBlue, vbBlack, vbGreen, vbYellow)
For nRow = 1 To 5
With ThisWorkbook.Worksheets( 1 ).Rows(nRow).Font
.Color = avColors(nRow - 1 )
.Name = avFonts(nRow - 1 )
If nRow Mod 2 = 0 Then
.Underline = True
Else
.Underline = False
End If
End With
Next
End Sub
Sub DemonstrateFontObject()
Dim nColumn As Long
Dim nRow As Long
Dim avFonts As Variant
Dim avColors As Variant
For nColumn = 1 To 5
With ThisWorkbook.Worksheets( 1 ).Columns(nColumn).Font
.Size = nColumn + 10
If nColumn Mod 2 = 0 Then
.Bold = True
.Italic = False
Else
.Bold = False
.Italic = True
End If
End With
Next
avFonts = Array ( " Tahoma " , " Arial " , " MS Sans Serif " , " Verdana " , " Georgia " )
avColors = Array (vbRed, vbBlue, vbBlack, vbGreen, vbYellow)
For nRow = 1 To 5
With ThisWorkbook.Worksheets( 1 ).Rows(nRow).Font
.Color = avColors(nRow - 1 )
.Name = avFonts(nRow - 1 )
If nRow Mod 2 = 0 Then
.Underline = True
Else
.Underline = False
End If
End With
Next
End Sub
10.1.3 内部布置
代码清单10.3:使用Interior对象改变一个范围的背景
代码
'
代码清单10.3:使用Interior对象改变一个范围的背景
' 表单名:Interior
' 命名两个名称:ListStart、ColorListStart
Sub InteriorExample()
Dim rg As Range
' create examples of each pattern
Set rg = ThisWorkbook.Worksheets( " Interior " ).Range( " ListStart " ).Offset( 1 , 0 )
Do Until IsEmpty (rg)
rg.Offset( 0 , 2 ).Interior.Pattern = rg.Offset( 0 , 1 ).Value
rg.Offset( 0 , 3 ).Interior.Pattern = rg.Offset( 0 , 1 ).Value
rg.Offset( 0 , 3 ).Interior.PatternColor = vbRed
Set rg = rg.Offset( 1 , 0 )
Loop
' create example of each vb defined color constant
Set rg = ThisWorkbook.Worksheets( " Interior " ).Range( " ColorListStart " ).Offset( 1 , 0 )
Do Until IsEmpty (rg)
rg.Offset( 0 , 2 ).Interior.Color = rg.Offset( 0 , 1 ).Value
Set rg = rg.Offset( 1 , 0 )
Loop
Set rg = Nothing
End Sub
' 表单名:Interior
' 命名两个名称:ListStart、ColorListStart
Sub InteriorExample()
Dim rg As Range
' create examples of each pattern
Set rg = ThisWorkbook.Worksheets( " Interior " ).Range( " ListStart " ).Offset( 1 , 0 )
Do Until IsEmpty (rg)
rg.Offset( 0 , 2 ).Interior.Pattern = rg.Offset( 0 , 1 ).Value
rg.Offset( 0 , 3 ).Interior.Pattern = rg.Offset( 0 , 1 ).Value
rg.Offset( 0 , 3 ).Interior.PatternColor = vbRed
Set rg = rg.Offset( 1 , 0 )
Loop
' create example of each vb defined color constant
Set rg = ThisWorkbook.Worksheets( " Interior " ).Range( " ColorListStart " ).Offset( 1 , 0 )
Do Until IsEmpty (rg)
rg.Offset( 0 , 2 ).Interior.Color = rg.Offset( 0 , 1 ).Value
Set rg = rg.Offset( 1 , 0 )
Loop
Set rg = Nothing
End Sub
代码清单10.4:漫步通过颜色面板
代码
'
代码10.4:漫步通过颜色面板
' 表单:Worksheets("Interior")
' 命名单元格:Range("ColorIndexListStart")
Sub ViewWorkbookColors()
Dim rg As Range
Dim nIndex As Long
Set rg = ThisWorkbook.Worksheets( " Interior " ).Range( " ColorIndexListStart " ).Offset( 1 , 0 )
For nIndex = 1 To 56
rg.Value = nIndex
rg.Offset( 0 , 1 ).Interior.ColorIndex = nIndex
rg.Offset( 0 , 2 ).Value = rg.Offset( 0 , 1 ).Interior.Color
Set rg = rg.Offset( 1 , 0 )
Next
Set rg = Nothing
End Sub
' 表单:Worksheets("Interior")
' 命名单元格:Range("ColorIndexListStart")
Sub ViewWorkbookColors()
Dim rg As Range
Dim nIndex As Long
Set rg = ThisWorkbook.Worksheets( " Interior " ).Range( " ColorIndexListStart " ).Offset( 1 , 0 )
For nIndex = 1 To 56
rg.Value = nIndex
rg.Offset( 0 , 1 ).Interior.ColorIndex = nIndex
rg.Offset( 0 , 2 ).Value = rg.Offset( 0 , 1 ).Interior.Color
Set rg = rg.Offset( 1 , 0 )
Next
Set rg = Nothing
End Sub
10.1.4 这些边界不需要签证
代码清单10.5:与Border对象相关联的各种属性
代码
'
代码清单10.5:与border对象关联的各种属性
' 表单:Worksheets("Borders")
' 命名单元格:Range("LineStyleListStart")
Sub BorderLineStyles()
Dim rg As Range
Set rg = ThisWorkbook.Worksheets( " Borders " ).Range( " LineStyleListStart " ).Offset( 1 , 0 )
Do Until IsEmpty (rg)
rg.Offset( 0 , 2 ).Borders(xlEdgeBottom).LineStyle = rg.Offset( 0 , 1 ).Value
Set rg = rg.Offset( 1 , 0 )
Loop
Set rg = Nothing
End Sub
' 表单:Worksheets("Borders")
' 命名单元格:Range("LineStyleListStart")
Sub BorderLineStyles()
Dim rg As Range
Set rg = ThisWorkbook.Worksheets( " Borders " ).Range( " LineStyleListStart " ).Offset( 1 , 0 )
Do Until IsEmpty (rg)
rg.Offset( 0 , 2 ).Borders(xlEdgeBottom).LineStyle = rg.Offset( 0 , 1 ).Value
Set rg = rg.Offset( 1 , 0 )
Loop
Set rg = Nothing
End Sub
代码清单10.6:代码清单10.5的一个替代方法
代码
'
代码清单10.6:代码清单10.5的另一个方法
' 表单:Worksheets("Borders")
' 命名单元格:Range("LineStyleListStart")
Sub BorderLineStyles2()
Dim rg As Range
Set rg = ThisWorkbook.Worksheets( " Borders " ).Range( " LineStyleListStart " )
rg.Offset( 1 , 2 ).Borders(xlEdgeBottom).LineStyle = xlContinuous
rg.Offset( 2 , 2 ).Borders(xlEdgeBottom).LineStyle = xlDash
rg.Offset( 3 , 2 ).Borders(xlEdgeBottom).LineStyle = xlDashDot
rg.Offset( 4 , 2 ).Borders(xlEdgeBottom).LineStyle = xlDashDotDot
rg.Offset( 5 , 2 ).Borders(xlEdgeBottom).LineStyle = xlDot
rg.Offset( 6 , 2 ).Borders(xlEdgeBottom).LineStyle = xlDouble
rg.Offset( 7 , 2 ).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
rg.Offset( 8 , 2 ).Borders(xlEdgeBottom).LineStyle = xlSlantDashDot
Set rg = Nothing
End Sub
' 表单:Worksheets("Borders")
' 命名单元格:Range("LineStyleListStart")
Sub BorderLineStyles2()
Dim rg As Range
Set rg = ThisWorkbook.Worksheets( " Borders " ).Range( " LineStyleListStart " )
rg.Offset( 1 , 2 ).Borders(xlEdgeBottom).LineStyle = xlContinuous
rg.Offset( 2 , 2 ).Borders(xlEdgeBottom).LineStyle = xlDash
rg.Offset( 3 , 2 ).Borders(xlEdgeBottom).LineStyle = xlDashDot
rg.Offset( 4 , 2 ).Borders(xlEdgeBottom).LineStyle = xlDashDotDot
rg.Offset( 5 , 2 ).Borders(xlEdgeBottom).LineStyle = xlDot
rg.Offset( 6 , 2 ).Borders(xlEdgeBottom).LineStyle = xlDouble
rg.Offset( 7 , 2 ).Borders(xlEdgeBottom).LineStyle = xlLineStyleNone
rg.Offset( 8 , 2 ).Borders(xlEdgeBottom).LineStyle = xlSlantDashDot
Set rg = Nothing
End Sub
10.1.5 格式化数字
代码清单10.7:试验格式代码
代码
'
代码清单10.7:试验格式代码
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = Me.Range( " FormatCode " ).Address Then
ApplyFormatCode
End If
End Sub
' 命名单元格Range("FormatCode")、Range("TestFormatCode")
Private Sub ApplyFormatCode()
' if we attempt to apply an invalid
' number format code an error will
' occur - we need to catch it
On Error GoTo ErrHandler
' clear any prior invalid code message
Me.Range( " FormatCode " ).Offset( 0 , 1 ).Value = ""
' attempt to apply the format code
Me.Range( " TestFormatCode " ).NumberFormat = Me.Range( " formatcode " ).Value
Exit Sub
ErrHandler:
' OOPS-invalid format code
' set the format to general
Me.Range( " TestFormatCode " ).NumberFormat = " general "
' let the user know what happened
Me.Range( " FormatCode " ).Offset( 0 , 1 ).Value = " Invalid Format Code! "
End Sub
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = Me.Range( " FormatCode " ).Address Then
ApplyFormatCode
End If
End Sub
' 命名单元格Range("FormatCode")、Range("TestFormatCode")
Private Sub ApplyFormatCode()
' if we attempt to apply an invalid
' number format code an error will
' occur - we need to catch it
On Error GoTo ErrHandler
' clear any prior invalid code message
Me.Range( " FormatCode " ).Offset( 0 , 1 ).Value = ""
' attempt to apply the format code
Me.Range( " TestFormatCode " ).NumberFormat = Me.Range( " formatcode " ).Value
Exit Sub
ErrHandler:
' OOPS-invalid format code
' set the format to general
Me.Range( " TestFormatCode " ).NumberFormat = " general "
' let the user know what happened
Me.Range( " FormatCode " ).Offset( 0 , 1 ).Value = " Invalid Format Code! "
End Sub
10.1.6 缩放工作表时节省大量时间
代码清单10.8:为报表提供动态缩放
代码
'
代码清单10.8: 为报表提供动态缩放
' 在表单中命名两个命名范围:Me.Range("ScaleFactor") 、Me.Range("ScaleRange")
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = Me.Range( " ScaleFactor " ).Address Then
ScaleData
End If
End Sub
Private Sub ScaleData()
If Me.Range( " ScaleFactor " ).Value = " Normal " Then
Me.Range( " ScaleRange " ).NumberFormat = " #,##0 "
Else
Me.Range( " scaleRange " ).NumberFormat = " #, "
End If
End Sub
' 在表单中命名两个命名范围:Me.Range("ScaleFactor") 、Me.Range("ScaleRange")
Private Sub Worksheet_Change(ByVal Target As Range)
If Target.Address = Me.Range( " ScaleFactor " ).Address Then
ScaleData
End If
End Sub
Private Sub ScaleData()
If Me.Range( " ScaleFactor " ).Value = " Normal " Then
Me.Range( " ScaleRange " ).NumberFormat = " #,##0 "
Else
Me.Range( " scaleRange " ).NumberFormat = " #, "
End If
End Sub
10.2 图表操作
10.2.1 从头创建图表
代码清单10.9:使用ChartWizard方法创建一个新图表
代码
'
代码清单10.9: 使用ChartWizard方法创建一个新图表
' creates a chart using the ChartWizard Method
Sub CreateExampleChartVersionI()
Dim ws As Worksheet
Dim rgChartData As Range
Dim chrt As Chart
Set ws = ThisWorkbook.Worksheets( " Basic Chart " )
Set rgChartData = ws.Range( " B1 " ).CurrentRegion
' create a new empty chart
Set chrt = Charts.Add
' embed chart in worksheet - this creates a new object
Set chrt = chrt.Location(xlLocationAsObject, ws.Name)
' use chart wizard to populate/format empty chart
chrt.ChartWizard _
Source: = rgChartData, _
Gallery: = xlColumn, _
Format : = 1 , _
PlotBy: = xlColumns, _
categorylabels: = 1 , _
serieslabels: = 1 , _
HasLegend: = True , _
Title: = " Gross Domestric Product Version I " , _
Categorytitle: = " year " , _
valuetitle: = " GDP in billions of $ "
Set chrt = Nothing
Set rgChartData = Nothing
Set ws = Nothing
End Sub
' creates a chart using the ChartWizard Method
Sub CreateExampleChartVersionI()
Dim ws As Worksheet
Dim rgChartData As Range
Dim chrt As Chart
Set ws = ThisWorkbook.Worksheets( " Basic Chart " )
Set rgChartData = ws.Range( " B1 " ).CurrentRegion
' create a new empty chart
Set chrt = Charts.Add
' embed chart in worksheet - this creates a new object
Set chrt = chrt.Location(xlLocationAsObject, ws.Name)
' use chart wizard to populate/format empty chart
chrt.ChartWizard _
Source: = rgChartData, _
Gallery: = xlColumn, _
Format : = 1 , _
PlotBy: = xlColumns, _
categorylabels: = 1 , _
serieslabels: = 1 , _
HasLegend: = True , _
Title: = " Gross Domestric Product Version I " , _
Categorytitle: = " year " , _
valuetitle: = " GDP in billions of $ "
Set chrt = Nothing
Set rgChartData = Nothing
Set ws = Nothing
End Sub
代码清单10.10:使用Chart对象创建一个图表
代码
'
代码清单10.10: 使用Chart对象创建一个新图表
' creates a chart using basic chart properties and Methods
Sub CreateExampleChartVersionII()
Dim ws As Worksheet
Dim rgChartData As Range
Dim chrt As Chart
Set ws = ThisWorkbook.Worksheets( " Basic Chart " )
Set rgChartData = ws.Range( " B1 " ).CurrentRegion
' create a new empty chart
Set chrt = Charts.Add
' embed chart in worksheet - this creates a new object
Set chrt = chrt.Location(xlLocationAsObject, ws.Name)
With chrt
.SetSourceData rgChartData, xlColumns
.HasTitle = True
.ChartTitle.Caption = " Gross Domestric Product Version II "
.ChartType = xlConeColClustered
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 chrt = Nothing
Set rgChartData = Nothing
Set ws = Nothing
End Sub
' creates a chart using basic chart properties and Methods
Sub CreateExampleChartVersionII()
Dim ws As Worksheet
Dim rgChartData As Range
Dim chrt As Chart
Set ws = ThisWorkbook.Worksheets( " Basic Chart " )
Set rgChartData = ws.Range( " B1 " ).CurrentRegion
' create a new empty chart
Set chrt = Charts.Add
' embed chart in worksheet - this creates a new object
Set chrt = chrt.Location(xlLocationAsObject, ws.Name)
With chrt
.SetSourceData rgChartData, xlColumns
.HasTitle = True
.ChartTitle.Caption = " Gross Domestric Product Version II "
.ChartType = xlConeColClustered
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 chrt = Nothing
Set rgChartData = Nothing
Set ws = Nothing
End Sub
10.2.2 图表搜索
可以像工作表一样引用图表页
代码
Dim
chrt1
As
Chart
Dim chrt2 As Chart
' set a reference to the chart sheet named Chart4
Set chrt1 = ThisWorkbook.Charts( " Chart4 " )
' set a reference to the 2nd chart sheet in this workbook
Set chrt2 = ThisWorkbook.Charts( 2 )
Dim chrt2 As Chart
' set a reference to the chart sheet named Chart4
Set chrt1 = ThisWorkbook.Charts( " Chart4 " )
' set a reference to the 2nd chart sheet in this workbook
Set chrt2 = ThisWorkbook.Charts( 2 )
如果图表嵌入在一个工作表中,我们需要使用ChartObjects集合。
代码
Dim
ws
As
Worksheet
Dim chrt1 As Chart
Dim chrt2 As Chart
Set ws = ThisWorkbook.Worksheets( 1 )
' set a reference to the embedded chart named Chart4
Set chrt1 = ws.ChartObjects( " Chart4 " ).Chart
' set a reference to the 2nd embedded chart
Set chrt2 = ws.ChartObjects( 2 ).Chart
Dim chrt1 As Chart
Dim chrt2 As Chart
Set ws = ThisWorkbook.Worksheets( 1 )
' set a reference to the embedded chart named Chart4
Set chrt1 = ws.ChartObjects( " Chart4 " ).Chart
' set a reference to the 2nd embedded chart
Set chrt2 = ws.ChartObjects( 2 ).Chart
代码清单10.11:使用图表标题查寻图表
代码
'
代码清单10.11: 使用图标题查寻图表
' searches charts on a worksheet by chart title
Function GetChartByCaption(ws As Worksheet, sCaption As String ) As Chart
Dim cht As Chart
Dim chtObj As ChartObject
Dim sTitle As String
Set cht = Nothing
' loop through all chart objects on the ws
For Each chtObj In ws.ChartObjects
' make sure current chart object chart has a title
If chtObj.Chart.HasTitle Then
sTitle = chtObj.Chart.ChartTitle.Caption
' is this title a match?
If StrComp (sTitle, sCaption, vbTextCompare) = 0 Then
' bingo
Set cht = chtObj.Chart
Exit For
End If
End If
Next
Set GetChartByCaption = cht
Set chtObj = Nothing
Set cht = Nothing
End Function
Sub TestGetChartByCaption()
Dim ws As Worksheet
Dim cht As Chart
Set ws = ThisWorkbook.Worksheets( " Basic Chart " )
Set cht = GetChartByCaption(ws, " I am the Chart Title " )
If Not cht Is Nothing Then
MsgBox " Found chart "
Else
MsgBox " Sorry, Can not Found chart "
End If
Set cht = Nothing
Set ws = Nothing
End Sub
' searches charts on a worksheet by chart title
Function GetChartByCaption(ws As Worksheet, sCaption As String ) As Chart
Dim cht As Chart
Dim chtObj As ChartObject
Dim sTitle As String
Set cht = Nothing
' loop through all chart objects on the ws
For Each chtObj In ws.ChartObjects
' make sure current chart object chart has a title
If chtObj.Chart.HasTitle Then
sTitle = chtObj.Chart.ChartTitle.Caption
' is this title a match?
If StrComp (sTitle, sCaption, vbTextCompare) = 0 Then
' bingo
Set cht = chtObj.Chart
Exit For
End If
End If
Next
Set GetChartByCaption = cht
Set chtObj = Nothing
Set cht = Nothing
End Function
Sub TestGetChartByCaption()
Dim ws As Worksheet
Dim cht As Chart
Set ws = ThisWorkbook.Worksheets( " Basic Chart " )
Set cht = GetChartByCaption(ws, " I am the Chart Title " )
If Not cht Is Nothing Then
MsgBox " Found chart "
Else
MsgBox " Sorry, Can not Found chart "
End If
Set cht = Nothing
Set ws = Nothing
End Sub
代码清单10.12:格式化一个基本图表
代码
'
代码清单10.12: 格式化一个基本图表
Sub FormattingCharts()
Dim ws As Worksheet
Dim cht As Chart
Dim ax As Axis
Set ws = ThisWorkbook.Worksheets( " Basic Chart " )
Set cht = GetChartByCaption(ws, " GDP " )
If Not cht Is Nothing Then
' Format category axis
Set ax = cht.Axes(xlCategory)
With ax
.AxisTitle.Font.Size = 12
.AxisTitle.Font.Color = vbRed
End With
' Format value axis
Set ax = cht.Axes(xlValue)
With ax
.HasMinorGridlines = True
.MinorGridlines.Border.LineStyle = xlDashDot
End With
' format plot area
With cht.PlotArea
.Border.LineStyle = xlDash
.Border.Color = vbRed
.Interior.Color = vbWhite
.Width = cht.PlotArea.Width + 10
.Height = cht.PlotArea.Height + 10
End With
' format misc other
cht.ChartArea.Interior.Color = vbWhite
cht.Legend.Position = xlLegendPositionBottom
End If
Set ax = Nothing
Set cht = Nothing
Set ws = Nothing
End Sub
Sub FormattingCharts()
Dim ws As Worksheet
Dim cht As Chart
Dim ax As Axis
Set ws = ThisWorkbook.Worksheets( " Basic Chart " )
Set cht = GetChartByCaption(ws, " GDP " )
If Not cht Is Nothing Then
' Format category axis
Set ax = cht.Axes(xlCategory)
With ax
.AxisTitle.Font.Size = 12
.AxisTitle.Font.Color = vbRed
End With
' Format value axis
Set ax = cht.Axes(xlValue)
With ax
.HasMinorGridlines = True
.MinorGridlines.Border.LineStyle = xlDashDot
End With
' format plot area
With cht.PlotArea
.Border.LineStyle = xlDash
.Border.Color = vbRed
.Interior.Color = vbWhite
.Width = cht.PlotArea.Width + 10
.Height = cht.PlotArea.Height + 10
End With
' format misc other
cht.ChartArea.Interior.Color = vbWhite
cht.Legend.Position = xlLegendPositionBottom
End If
Set ax = Nothing
Set cht = Nothing
Set ws = Nothing
End Sub