第10章 其他Excel对象

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

 

 

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

 

 

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

 

 

代码清单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

 

 

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

 

 

代码清单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

 

 

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

 

 

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

 

 

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

 

 

代码清单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

 

 

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 )

 

如果图表嵌入在一个工作表中，我们需要使用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

 

 

代码清单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

 

 

代码清单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