10.1 产生一个好的第一印象
代码
代码
代码
代码
代码
代码
代码
代码
代码
代码
代码
代码
代码
代码
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
