VBA在Excel中的应用（二）

http://www.cnblogs.com/jaxu/archive/2009/04/30/1446619.html

目录

 AutoFilter 
 Binding 
 Cell Comments 
 Cell Copy 
 Cell Format 
 Cell Number Format 
 Cell Value 
 Cell 

AutoFilter

1. 1. 确认当前工作表是否开启了自动筛选功能
   Sub   filter () 
         If  ActiveSheet.AutoFilterMode  Then  
            MsgBox   " Turned on "  
         End   If  
   End Sub
   当工作表中有单元格使用了自动筛选功能，工作表的AutoFilterMode的值将为True，否则为False。
2. 2. 使用Range.AutoFilter方法 
   
   Sub  Test() 
   Worksheets( " Sheet1 " ).Range( " A1 " ).AutoFilter _ 
       field: = 1 , _ 
       Criteria1: = " Otis "  
       VisibleDropDown: = False  
   End Sub
   以上是一段来源于Excel帮助文档的例子，它从A1单元格开始筛选出值为Otis的单元格。Range.AutoFilter方法可以带参数也可以不带参数。当不带参数时，表示在Range对象所指定的区域内执行“筛选”菜单命令，即仅显示一个自动筛选下拉箭头，这种情况下如果再次执行Range.AutoFilter方法则可以取消自动筛选；当带参数时，可根据给定的参数在Range对象所指定的区域内进行数据筛选，只显示符合筛选条件的数据。参数Field为筛选基准字段的整型偏移量，Criterial1、Operator和Criterial2三个参数一起组成了筛选条件，最后一个参数VisibleDropDown用来指定是否显示自动筛选下拉箭头。 
   其中Field参数可能不太好理解，这里给一下说明：

用上面的代码结合这个截图，如果从A1单元格开始进行数据筛选，如果Field的值为1，则表示取列表中的第一个字段即B列，以此类推，如果Field的值为2则表示C列…不过前提是所有的待筛选列表是连续的，就是说中间不能有空列。当然也可以这样，使用Range(“A1:E17”).AutoFilter，这样即使待筛选列表中有空列也可以，因为已经指定了一个待筛选区域。Field的值表示的就是将筛选条件应用到所表示的列上。下面是一些使用AutoFilter的例子。

Sub  SimpleOrFilter() 
    Worksheets( " SalesReport " ).Select 
    Range( " A1 " ).AutoFilter 
    Range( " A1 " ).AutoFilter Field: = 4 ,Criteria1: = " =A " , Operator: = xlOr, Criteria2: = " =B "  
End Sub

 

Sub  SimpleAndFilter() 
    Worksheets( " SalesReport " ).Select 
    Range( " A1 " ).AutoFilter 
    Range( " A1 " ).AutoFilter Field: = 4 , _ 
        Criteria1: = " >=A " , _ 
        Operator: = xlAnd, Criteria2: = " <=EZZ "  
End Sub

 

Sub  Top10Filter() 
     '  Top 12 Revenue Records  
    Worksheets( " SalesReport " ).Select 
    Range( " A1 " ).AutoFilter 
    Range( " A1 " ).AutoFilter Field: = 6 , Criteria1: = " 12 " ,Operator: = xlTop10Items 
End Sub

 

Sub  MultiSelectFilter() 
    Worksheets( " SalesReport " ).Select 
    Range( " A1 " ).AutoFilter 
    Range( " A1 " ).AutoFilter Field: = 4 , Criteria1: = Array ( " A " ,  " C " ,  " E " , " F " ,  " H " ),Operator: = xlFilterValues 
End Sub

 

Sub  DynamicAutoFilter() 
    Worksheets( " SalesReport " ).Select 
    Range( " A1 " ).AutoFilter 
    Range( " A1 " ).AutoFilter Field: = 3 ,Criteria1: = xlFilterNextYear,Operator: = xlFilterDynamic 
End Sub

 

Sub  FilterByIcon() 
    Worksheets( " SalesReport " ).Select 
    Range( " A1 " ).AutoFilter 
    Range( " A1 " ).AutoFilter Field: = 6 , _ 
        Criteria1: = ActiveWorkbook.IconSets(xl5ArrowsGray).Item( 5 ),Operator: = xlFilterIcon 
End Sub

 

Sub  FilterByFillColor() 
    Worksheets( " SalesReport " ).Select 
    Range( " A1 " ).AutoFilter 
    Range( " A1 " ).AutoFilter Field: = 6 , Criteria1: = RGB ( 255 ,  0 ,  0 ), Operator: = xlFilterCellColor 
End Sub

下面的程序是通过Excel的AutoFilter功能快速删除行的方法，供参考：

Sub  DeleteRows3() 
     Dim  lLastRow  As   Long         ' Last row  
     Dim  rng  As  range 
     Dim  rngDelete  As  range 
     ' Freeze screen  
    Application.ScreenUpdating  =   False  
     ' Insert dummy row for dummy field name  
    Rows( 1 ).Insert 
     ' Insert dummy field name  
    range( " C1 " ).value  =   " Temp "  
     With  ActiveSheet 
        .UsedRange 
        lLastRow  =  .cells.SpecialCells(xlCellTypeLastCell).row 
         Set  rng  =  range( " C1 " , cells(lLastRow,  " C " )) 
        rng.AutoFilter Field: = 1 , Criteria1: = " Mangoes "  
         Set  rngDelete  =  rng.SpecialCells(xlCellTypeVisible) 
        rng.AutoFilter 
        rngDelete.EntireRow.delete 
        .UsedRange 
     End   With  
End Sub

 返回目录

 Binding

1. 1. 一个使用早期Binging的例子
   

   Sub  EarlyBinding() 
        Dim  objExcel  As  Excel.Application 
        Set  objExcel  =   New  Excel.Application 
        With  objExcel 
           .Visible  =   True  
           .Workbooks.Add 
           .Range( " A1 " )  =   " Hello World "  
        End   With  
   End Sub

   
2. 2. 使用CreateObject创建Excel实例
   

   Sub  LateBinding() 
   
        ' Declare a generic object variable  
        Dim  objExcel  As   Object  
   
        ' Point the object variable at an Excel application object  
        Set  objExcel  =   CreateObject ( " Excel.Application " ) 
   
        ' Set properties and execute methods of the object  
        With  objExcel 
           .Visible  =   True  
           .Workbooks.Add 
           .Range( " A1 " )  =   " Hello World "  
        End   With  
   
   End Sub

   
3. 3. 使用CreateObject创建指定版本的Excel实例
   Sub  mate() 
        Dim  objExcel  As   Object  
   
        Set  objExcel  =   CreateObject ( " Excel.Application.8 " ) 
   End Sub

              当Create对象实例之后，就可以使用该对象的所有属性和方法了，如SaveAs方法、Open方法、Application属性等。

 返回目录

 Cell Comments

1. 1. 获取单元格的备注
   Private   Sub  CommandButton1_Click() 
        Dim  strGotIt  As   String  
       strGotIt  =  WorksheetFunction.Clean(Range( " A1 " ).Comment.Text) 
        MsgBox  strGotIt 
   End Sub

   Range.Comment.Text用于得到单元格的备注文本，如果当前单元格没有添加备注，则会引发异常。注意代码中使用了WorksheetFunction对象，该对象是Excel的系统对象，它提供了很多系统函数，这里用到的Clean函数用于清楚指定文本中的所有关键字（特殊字符），具体信息可以查阅Excel自带的帮助文档，里面提供的函数非常多。下面是一个使用Application.WorksheetFunction.Substitute函数的例子，其中第一个Substitute将给定的字符串中的author:替换为空字符串，第二个Substitute将给定的字符串中的空格替换为空字符串。

   

   Private   Function  CleanComment(author  As   String , cmt  As   String )  As   String  
        Dim  tmp  As   String  
   
       tmp  =  Application.WorksheetFunction.Substitute(cmt, author  &   " : " ,  "" ) 
       tmp  =  Application.WorksheetFunction.Substitute(tmp,  Chr ( 10 ),  "" ) 
   
       CleanComment  =  tmp 
   End Function

   
2. 2. 修改Excel单元格内容时自动给单元格添加Comments信息
   

   Private   Sub  Worksheet_Change(ByVal Target  As  Excel.Range) 
        Dim  newText  As   String  
        Dim  oldText  As   String  
        
        For   Each  cell In Target 
            With  cell 
                On   Error   Resume   Next  
               oldText  =  .Comment.Text 
                If  Err  <>   0   Then  .AddComment 
               newText  =  oldText  &   "  Changed by  "   &  Application.UserName  &   "  at  "   &   Now   &  vbLf 
                MsgBox  newText 
               .Comment.Text newText 
               .Comment.Visible  =   True  
               .Comment.Shape.Select 
                Selection.AutoSize  =   True  
               .Comment.Visible  =   False  
            End   With  
        Next  cell 
   End Sub

   
   Comments内容可以根据需要自己修改，Worksheet_Change方法在Worksheet单元格内容被修改时执行。
3. 3. 改变Comment标签的显示状态
   

   Sub  ToggleComments() 
        If  Application.DisplayCommentIndicator  =  xlCommentAndIndicator  Then  
           Application.DisplayCommentIndicator  =  xlCommentIndicatorOnly 
        Else  
           Application.DisplayCommentIndicator  =  xlCommentAndIndicator 
        End   If  
   End Sub

   
   Application.DisplayCommentIndicator有三种状态：xlCommentAndIndicator-始终显示Comment标签、xlCommentIndicatorOnly-当鼠标指向单元格的Comment pointer时显示Comment标签、xlNoIndicator-隐藏Comment标签和单元格的Comment pointer。
4. 4. 改变Comment标签的默认大小
   Sub  CommentFitter1() 
        With  Range( " A1 " ).Comment 
           .Shape.Width  =   150  
           .Shape.Height  =   300  
        End   With  
   End Sub
   注意：旧版本中的Range.NoteText方法同样可以返回单元格中的Comment，按照Excel的帮助文档中的介绍，建议在新版本中统一使用Range.Comment方法。

 返回目录

 Cell Copy

1. 1. 从一个Sheet中的Range拷贝数据到另一个Sheet中的Range
   

   Private   Sub  CommandButton1_Click() 
        Dim  myWorksheet  As  Worksheet 
        Dim  myWorksheetName  As   String  
        
       myWorksheetName  =   " MyName "  
       Sheets.Add.Name  =  myWorksheetName 
       Sheets(myWorksheetName).Move After: = Sheets(Sheets.Count) 
       Sheets( " Sheet1 " ).Range( " A1:A5 " ).Copy Sheets(myWorksheetName).Range( " A1 " ) 
   End Sub

   
   Sheets.Add.Name = myWorksheetName用于在Sheets集合中添加名称为myWorksheetName的Sheet，Sheets(myWorksheetName).Move After:=Sheets(Sheets.Count)将刚刚添加的这个Sheet移到Sheets集合中最后一个元素的后面，最后Range.Copy方法将数据拷贝到新表中对应的单元格中。

 返回目录

 Cell Format

1. 1. 设置单元格文字的颜色
   Sub  fontColor() 
       Cells.Font.Color  =  vbRed 
   End Sub
   Color的值可以通过RGB(0,225,0)这种方式获取，也可以使用Color常数：

   常数	值	描述
   vbBlack	0x0	黑色
   vbRed	0xFF	红色
   vbGreen	0xFF00	绿色
   vbYellow	0xFFFF	黄色
   vbBlue	0xFF0000	蓝色
   vbMagenta	0xFF00FF	紫红色
   vbCyan	0xFFFF00	青色
   vbWhite	0xFFFFFF	白色

2. 2. 通过ColorIndex属性修改单元格字体的颜色 
   通过上面的方法外，还可以通过指定Range.Font.ColorIndex属性来修改单元格字体的颜色，该属性表示了调色板中颜色的索引值，也可以指定一个常量，xlColorIndexAutomatic（-4105）为自动配色，xlColorIndexNone（-4142）表示无色。
3. 3. 一个Format单元格的例子
   

   Sub  cmd() 
       Cells( 1 ,  " D " ).Value  =   " Text "  
       Cells( 1 ,  " D " ).Select 
        
        With  Selection 
           .Font.Bold  =   True  
           .Font.Name  =   " Arial "  
           .Font.Size  =   72  
           .Font.Color  =   RGB ( 0 ,  0 ,  255 )   ' Dark blue  
           .Columns.AutoFit 
           .Interior.Color  =   RGB ( 0 ,  255 ,  255 )  ' Cyan  
           .Borders.Weight  =  xlThick 
           .Borders.Color  =   RGB ( 0 ,  0 ,  255 )   ' Dark Blue  
        End   With  
   End Sub

   
4. 4. 指定单元格的边框样式
   Sub  UpdateBorder 
       range( " A1 " ).Borders(xlRight).LineStyle  =  xlLineStyleNone 
       range( " A1 " ).Borders(xlLeft).LineStyle  =  xlContinuous 
       range( " A1 " ).Borders(xlBottom).LineStyle  =  xlDashDot 
       range( " A1 " ).Borders(xlTop).LineStyle  =  xlDashDotDot     
   End Sub
   如果要为Range的四个边框设置同样的样式，可以直接设置Range.Borders.LineStyle的值，该值为一个常数：

   名称	值	描述
   xlContinuous	1	实线
   xlDash	-4115	虚线
   xlDashDot	4	点划相间线
   xlDashDotDot	5	划线后跟两个点
   xlDot	-4118	点式线
   xlDouble	-4119	双线
   xlLineStyleNone	-4142	无线
   xlSlantDashDot	13	倾斜的划线

 返回目录

 Cell Number Format

1. 改变单元格数值的格式
   

   Sub  FormatCell() 
        Dim  myVar  As  Range 
        Set  myVar  =  Selection 
        With  myVar 
           .NumberFormat  =   " #,##0.00_);[Red](#,##0.00) "  
           .Columns.AutoFit 
        End   With  
   
   End Sub

   
   单元格数值的格式有很多种，如数值、货币、日期等，具体的格式指定样式可以通过录制Excel宏得知，在Excel的Sheet中选中一个单元格，然后单击右键，选择“设置单元格格式”，在“数字”选项卡中进行选择。

 返回目录

 Cell Value

1. 1. 使用STRConv函数转换Cell中的Value值
   Sub  STRConvDemo() 
       Cells( 3 ,  " A " ).Value  =  STRConv( " ALL LOWERCASE  " , vbLowerCase) 
   End Sub

   STRConv是一个功能很强的系统函数，它可以按照指定的转换类型转换字符串值，如大小写转换、将字符串中的首字母大写、单双字节字符转换、平假名片假名转换、Unicode字符集转换等。具体的使用规则和参数类型读者可以查阅一下Excel自带的帮助文档，在帮助中输入STRConv，查看搜索结果中的第一项。

2. 2. 使用Format函数进行字符串的大小写转换
   Sub  callLower() 
       Cells( 2 ,  " A " ).Value  =  Format( " ALL LOWERCASE  " ,  " < " ) 
   End Sub
   Format也是一个非常常用的系统函数，它用于格式化输出字符串，有关Format的使用读者可以查看Excel自带的帮助文档。Format函数有很多的使用技巧，如本例给出的<可以将字符串转换为小写形式，相应地，>则可以将字符串转换为大写形式。
3. 3. 一种引用单元格的快捷方法
   Sub  GetSum()                     '  using the shortcut approach  
       [A1].Value  =  Application.Sum([E1:E15]) 
   End Sub
   [A1]即等效于Range("A1")，这是一种引用单元格的快捷方法，在公式中同样也可以使用。
4. 4. 计算单元格中的公式
   Sub  CalcCell() 
         Worksheets( " Sheet1 " ).range( " A1 " ).Calculate 
   End Sub
   示例中的代码将计算Sheet1工作表中A1单元格的公式，相应地，Application.Calculate可以计算所有打开的工作簿中的公式。
5. 5. 一个用于检查单元格数据类型的例子
   

   Function  CellType(Rng) 
       Application.Volatile 
        Set  Rng  =  Rng.Range( " A1 " ) 
        Select   Case   True  
            Case   IsEmpty (Rng) 
               CellType  =   " Blank "  
            Case  WorksheetFunction.IsText(Rng) 
               CellType  =   " Text "  
            Case  WorksheetFunction.IsLogical(Rng) 
               CellType  =   " Logical "  
            Case  WorksheetFunction.IsErr(Rng) 
               CellType  =   " Error "  
            Case   IsDate (Rng) 
               CellType  =   " Date "  
            Case   InStr ( 1 , Rng.Text,  " : " )  <>   0  
               CellType  =   " Time "  
            Case   IsNumeric (Rng) 
               CellType  =   " Value "  
        End   Select  
   End Function

   
   Application.Volatile用于将用户自定义函数标记为易失性函数，有关该方法的具体应用，读者可以查阅Excel自带的帮助文档。
6. 6. 一个Excel单元格行列变换的例子
   

   Public   Sub  Transpose() 
        Dim  I  As   Integer  
        Dim  J  As   Integer  
        Dim  transArray( 9 ,  2 )  As   Integer  
        For  I  =   1   To   3  
            For  J  =   1   To   10  
               transArray(J  -   1 , I  -   1 )  =  Cells(J,  Chr (I  +   64 )).Value 
            Next  J 
        Next  I 
       Range( " A1:C10 " ).ClearContents 
        For  I  =   1   To   3  
            For  J  =   1   To   10  
               Cells(I,  Chr (J  +   64 )).Value  =  transArray(J  -   1 , I  -   1 ) 
            Next  J 
        Next  I 
   End Sub

   
   该示例将A1:C10矩阵中的数据进行行列转换。 
   转换前： 
   转换后：
7. 7. VBA中冒泡排序示例
   

   Public   Sub  BubbleSort2() 
        Dim  tempVar  As   Integer  
        Dim  anotherIteration  As   Boolean  
        Dim  I  As   Integer  
        Dim  myArray( 10 )  As   Integer  
        For  I  =   1   To   10  
           myArray(I  -   1 )  =  Cells(I,  " A " ).Value 
        Next  I 
        Do  
           anotherIteration  =   False  
            For  I  =   0   To   8  
                If  myArray(I)  >  myArray(I  +   1 )  Then  
                   tempVar  =  myArray(I) 
                   myArray(I)  =  myArray(I  +   1 ) 
                   myArray(I  +   1 )  =  tempVar 
                   anotherIteration  =   True  
                End   If  
            Next  I 
        Loop   While  anotherIteration  =   True  
        For  I  =   1   To   10  
           Cells(I,  " B " ).Value  =  myArray(I  -   1 ) 
        Next  I 
   End Sub

   
   该实例将A1:A10中的数值按从小到大的顺序进行并，并输出到B1:B10的单元格中。 
   
8. 8. 一个验证Excel单元格数据输入规范的例子
   

   Private   Sub  Worksheet_Change(ByVal Target  As  Range) 
        Dim  cellContents  As   String  
        Dim  valLength  As   Integer  
       cellContents  =   Trim (Str(Val(Target.Value))) 
       valLength  =   Len (cellContents) 
        If  valLength  <>   3   Then  
            MsgBox  ( " Please enter a 3 digit area code. " ) 
           Cells( 9 ,  " C " ).Select 
        Else  
           Cells( 9 ,  " C " ).Value  =  cellContents 
           Cells( 9 ,  " D " ).Select 
        End   If  
   End Sub

   
   重点看一下Val函数，该函数返回给定的字符串中的数字，数字之外的字符将被忽略掉，该示例用于检测用户单元格的输入值，如果输入值中包含的数字个数不等于3，则提示用户，否则就将其中的数字赋值给另一个单元格。

 返回目录

 Cell

1. 1. 查找最后一个单元格
   

   Sub  GetLastCell()
       Dim  RealLastRow  As   Long
       Dim  RealLastColumn  As   Long
      
      Range( " A1 " ).Select
       On   Error   Resume   Next
      RealLastRow  =  Cells.Find( " * " , Range( " A1 " ), xlFormulas, , xlByRows, xlPrevious).Row
      RealLastColumn  =  Cells.Find( " * " , Range( " A1 " ), xlFormulas, , xlByColumns, xlPrevious).Column
      Cells(RealLastRow, RealLastColumn).Select
   End Sub

   
   该示例用来查找出当前工作表中的最后单元，并将其选中，主要使用了Cells对象的Find方法，有关该方法的详细说明读者可以参考Excel自带的帮助文档，搜索Cells.Find，见Range.Find方法的说明。
2. 2. 判断一个单元格是否为空
   

   Sub  ShadeEveryRowWithNotEmpty()
      Dim  i  As   Integer
     i  =   1
      Do  Until  IsEmpty (Cells(i,  1 ))
       Cells(i,  1 ).EntireRow.Interior.ColorIndex  =   15
       i  =  i  +   1
      Loop
   End Sub

   
   IsEmpty函数本是用来判断变量是否已经初始化的，它也可以被用来判断单元格是否为空，该示例从A1单元格开始向下检查单元格，将其所在行的背景色设置成灰色，直到下一个单元格的内容为空。
3. 3. 判断当前单元格是否为空的另外一种方法
   Sub  IsActiveCellEmpty()
        Dim  sFunctionName  As   String , sCellReference  As   String
       sFunctionName  =   " ISBLANK "
       sCellReference  =  ActiveCell.Address
        MsgBox  Evaluate(sFunctionName  &   " ( "   &  sCellReference  &   " ) " )
   End Sub
   Evaluate方法用来计算给定的表达式，如计算一个公式Evaluate("Sin(45)")，该示例使用Evaluate方法计算ISBLANK表达式，该表达式用来判断指定的单元格是否为空，如Evaluate(ISBLANK(A1))。
4. 4. 一个在给定的区域中找出数值最大的单元格的例子
   

   Sub  GoToMax()
        Dim  WorkRange  As  range
   
        If   TypeName (Selection)  <>   " Range "   Then   Exit   Sub
   
        If  Selection.Count  =   1   Then
            Set  WorkRange  =  Cells
        Else
            Set  WorkRange  =  Selection
        End   If
       MaxVal  =  Application.Max(WorkRange)
        On   Error   Resume   Next
       WorkRange.Find(What: = MaxVal, _
           After: = WorkRange.range( " A1 " ), _
           LookIn: = xlValues, _
           LookAt: = xlPart, _
           SearchOrder: = xlByRows, _
           SearchDirection: = xlNext, MatchCase: = False  _
           ).Select
        If  Err  <>   0   Then   MsgBox   " Max value was not found:  "  _
         &  MaxVal
   End Sub

   
5. 5. 使用数组更快地填充单元格区域
   

   Sub  ArrayFillRange()
        Dim  TempArray()  As   Integer
        Dim  TheRange  As  range
   
       CellsDown  =   3
       CellsAcross  =   4
       StartTime  =   timer
   
        ReDim  TempArray( 1   To  CellsDown,  1   To  CellsAcross)
        Set  TheRange  =  ActiveCell.range(Cells( 1 ,  1 ), Cells(CellsDown, CellsAcross))
       CurrVal  =   0
       Application.ScreenUpdating  =   False
        For  I  =   1   To  CellsDown
            For  J  =   1   To  CellsAcross
               TempArray(I, J)  =  CurrVal  +   1
               CurrVal  =  CurrVal  +   1
            Next  J
        Next  I
   
       TheRange.value  =  TempArray
       Application.ScreenUpdating  =   True
        MsgBox  Format( timer   -  StartTime,  " 00.00 " )  &   "  seconds "
   End Sub

   
   该示例展示了将一个二维数组直接赋值给一个“等效”单元格区域的方法，利用该方法可以使用数组直接填充单元格区域，结合下面这个直接在循环中填充单元格区域的方法，读者可以自己验证两种方法在效率上的差别。
   

   Sub  LoopFillRange()
        Dim  CurrRow  As   Long , CurrCol  As   Integer
        Dim  CurrVal  As   Long
   
       CellsDown  =   3
       CellsAcross  =   4
       StartTime  =   timer
       CurrVal  =   1
       Application.ScreenUpdating  =   False
        For  CurrRow  =   1   To  CellsDown
            For  CurrCol  =   1   To  CellsAcross
               ActiveCell.Offset(CurrRow  -   1 , _
               CurrCol  -   1 ).value  =  CurrVal
               CurrVal  =  CurrVal  +   1
            Next  CurrCol
        Next  CurrRow
   
   '    Display elapsed time
       Application.ScreenUpdating  =   True
        MsgBox  Format( timer   -  StartTime,  " 00.00 " )  &   "  seconds "
   End Sub

   

 返回目录