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 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 FilterByIcon()
    Worksheets("SalesReport").Select
    Range("A1").AutoFilter
    Range("A1").AutoFilter Field:=6, _
        Criteria1:=ActiveWorkbook.IconSets(xl5ArrowsGray).Item(5),Operator:=xlFilterIcon
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

 返回目录

 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