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参数可能不太好理解，这里给一下说明：

11

用上面的代码结合这个截图，如果从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矩阵中的数据进行行列转换。
    转换前：trans1
    转换后：trans2
  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的单元格中。
    BubbleSort2
  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
    复制代码
 返回目录
posted @ 2023-04-15 23:16  快乐58  阅读(699)  评论(0)    收藏  举报