VBA在Excel中的应用（二）

最新推荐文章于 2024-05-23 16:28:12 发布

ddjq1044

最新推荐文章于 2024-05-23 16:28:12 发布

阅读量362

点赞数

原文链接：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. 确认当前工作表是否开启了自动筛选功能
Sub filter ()
     If ActiveSheet.AutoFilterMode Then
        MsgBox " Turned on "
     End If
End Sub
当工作表中有单元格使用了自动筛选功能，工作表的AutoFilterMode的值将为True，否则为False。
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. 一个使用早期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. 使用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. 使用CreateObject创建指定版本的Excel实例
Sub mate()
Dim objExcel As Object

Set objExcel = CreateObject ( " Excel.Application.8 " )
End Sub

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

返回目录

Cell Comments

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. 修改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. 改变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. 改变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. 从一个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. 设置单元格文字的颜色
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. 通过ColorIndex属性修改单元格字体的颜色
通过上面的方法外，还可以通过指定Range.Font.ColorIndex属性来修改单元格字体的颜色，该属性表示了调色板中颜色的索引值，也可以指定一个常量，xlColorIndexAutomatic（-4105）为自动配色，xlColorIndexNone（-4142）表示无色。
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. 指定单元格的边框样式

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

改变单元格数值的格式
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. 使用STRConv函数转换Cell中的Value值
Sub STRConvDemo()
Cells( 3 , " A " ).Value = STRConv( " ALL LOWERCASE " , vbLowerCase)
End Sub

STRConv是一个功能很强的系统函数，它可以按照指定的转换类型转换字符串值，如大小写转换、将字符串中的首字母大写、单双字节字符转换、平假名片假名转换、Unicode字符集转换等。具体的使用规则和参数类型读者可以查阅一下Excel自带的帮助文档，在帮助中输入STRConv，查看搜索结果中的第一项。
2. 使用Format函数进行字符串的大小写转换
Sub callLower()
Cells( 2 , " A " ).Value = Format( " ALL LOWERCASE " , " < " )
End Sub
Format也是一个非常常用的系统函数，它用于格式化输出字符串，有关Format的使用读者可以查看Excel自带的帮助文档。Format函数有很多的使用技巧，如本例给出的<可以将字符串转换为小写形式，相应地，>则可以将字符串转换为大写形式。
3. 一种引用单元格的快捷方法
Sub GetSum() ' using the shortcut approach
[A1].Value = Application.Sum([E1:E15])
End Sub
[A1]即等效于Range("A1")，这是一种引用单元格的快捷方法，在公式中同样也可以使用。
4. 计算单元格中的公式
Sub CalcCell()
Worksheets( " Sheet1 " ).range( " A1 " ).Calculate
End Sub
示例中的代码将计算Sheet1工作表中A1单元格的公式，相应地，Application.Calculate可以计算所有打开的工作簿中的公式。
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. 一个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. 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. 一个验证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. 查找最后一个单元格
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. 判断一个单元格是否为空
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. 判断当前单元格是否为空的另外一种方法
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. 一个在给定的区域中找出数值最大的单元格的例子
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. 使用数组更快地填充单元格区域
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

返回目录

转载于:https://www.cnblogs.com/jaxu/archive/2009/04/30/1446619.html

ddjq1044

关注

0
点赞
踩
0

收藏

觉得还不错? 一键收藏
0
评论
复制链接

分享到 QQ

分享到新浪微博

扫一扫

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