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
    复制代码
 返回目录

 


本文转自Jaxu博客园博客,原文链接:http://www.cnblogs.com/jaxu/archive/2009/04/30/1446619.html,如需转载请自行联系原作者


相关文章
|
25天前
|
数据安全/隐私保护
杨老师课堂之Excel VBA 程序开发第七讲之自动筛选
杨老师课堂之Excel VBA 程序开发第七讲之自动筛选
18 1
|
25天前
|
数据安全/隐私保护
杨老师课堂之Excel VBA 程序开发第六讲根据部门列创建工作表
杨老师课堂之Excel VBA 程序开发第六讲根据部门列创建工作表
15 0
|
21天前
Excel如何使用VBA操作引用其它工作簿中的单元格
Excel引用其它工作簿中的单元格的值及使用VBA操作
|
21天前
|
机器学习/深度学习 安全 关系型数据库
Excel VBA的分层对象集合及外部对象库
基于对象的Excel VBA的分层对象集合及外部对象库
|
21天前
VBA如何用Excel数据批量生成Word文档
VBA|用Excel数据批量生成并修改用模板创建的Word文档
|
25天前
|
数据安全/隐私保护
杨老师课堂之Excel VBA 程序开发第六讲 根据制定列创建相应工作表及数据
杨老师课堂之Excel VBA 程序开发第六讲 根据制定列创建相应工作表及数据
17 1
|
25天前
|
数据安全/隐私保护
杨老师课堂之Excel VBA 程序开发第七讲自动备份
杨老师课堂之Excel VBA 程序开发第七讲自动备份
13 0
|
2月前
|
前端开发 Java
基于Java爬取微博数据(二) 正文长文本+导出数据Excel
【5月更文挑战第12天】基于Java爬取微博数据,正文长文本+导出数据Excel
|
26天前
|
easyexcel Java API
SpringBoot集成EasyExcel 3.x:高效实现Excel数据的优雅导入与导出
SpringBoot集成EasyExcel 3.x:高效实现Excel数据的优雅导入与导出
106 1
|
27天前
|
JSON 资源调度 JavaScript
蓝易云 - vue实现导出excel的多种方式
以上两种方式都可以实现在Vue中导出Excel的功能,你可以根据你的需求选择合适的方式。
22 1