VBA在Excel中的应用（二）

目录

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

返回目录