VBA在Excel中的应用(四)

http://www.cnblogs.com/jaxu/archive/2009/07/17/1525571.html

目录

 Column
 ComboBox
 Copy Paste 
 CountA 
 Evaluate 
 Excel to XML 
 Excel ADO 
 Excel to Text File 
 Excel Toolbar 

Column

  1. 1. 选择整列
    Sub  SelectEntireColumn()
        Selection.EntireColumn.Select
    End Sub
  2. 2. 将指定的列序号转换为列名
    复制代码
    Function  GetColumnRef(columnIndex  As   Integer As   String
        
    Dim  firstLetter  As   String
        
    Dim  secondLetter  As   String
        
    Dim  remainder  As   Integer

        
    Select   Case  columnIndex  /   26
            
    Case   Is   <=   1        ' Column ref is between A and Z
                firstLetter  =   Chr (columnIndex  +   64 )
                GetColumnRef 
    =  firstLetter
            
    Case   Else        ' Column ref has two letters
                remainder  =  columnIndex  -   26   *  (columnIndex  \   26 )
                
    If  remainder  =   0   Then
                    firstLetter 
    =   Chr ( 64   +  (columnIndex  \   26 -   1 )
                    secondLetter 
    =   " Z "
                    GetColumnRef 
    =  firstLetter  &  secondLetter
                
    Else
                    firstLetter 
    =   Chr ( 64   +  (columnIndex  \   26 ))
                    secondLetter 
    =   Chr ( 64   +  remainder)
                    GetColumnRef 
    =  firstLetter  &  secondLetter
                
    End   If
        
    End   Select
    End Function
    复制代码
    如columnIndex为11则转换后的列名为K,columnIndex为111则转换后的列名为DG。 
  3. 3. 将数组直接赋值给Columns
    复制代码
    Private   Sub  CommandButton1_Click()
        
    Dim  MyArray( 5 )
        
    For  i  =   1   To   5
            MyArray(i 
    -   1 =  i
        
    Next  i
        Cells.Clear
        Range(Cells(
    1 1 ), Cells( 1 5 ))  =  MyArray
    End Sub
    复制代码
  4. 4. 指定Column的宽度
    Sub  colDemo()
         ActiveCell.ColumnWidth 
    =   20
    End Sub
    又如Range("C1").ColumnWidth = Range("A1").ColumnWidth
  5. 5. 清除Columns的内容
    Sub  clear()
        Columns.clear
    End Sub
    这将导致当前Sheet中所有的内容被清除,等同于Cells.Clear,如果要清除特定列中的内容,可以给Columns加上参数。其它相关的还有Columns.ClearContents,Columns.ClearFormats,Columns.AutoFit,Columns.NumberFormat = "0.00%"等,与Cells对象中提供的诸多方法相似。


 返回目录

 ComboBox

  1. 1. 填充数据到ComboBox
    复制代码
    Private   Sub  Workbook_Open()
        
    Dim  vMonths  As  Variant
        
    Dim  vYears  As  Variant
        
    Dim  i  As   Integer

        
    ' Create date arrays
        vMonths  =  Array( " Jan " " Feb " " Mar " " Apr " " May " " Jun " , _
                            
    " Jul " " Aug " " Sep " " Oct " " Nov " " Dec " )
        vYears 
    =  Array( 2006 2007 )

        
    ' Populate months using AddItem method
         For  i  =   LBound (vMonths)  To   UBound (vMonths)
            Sheet1.ComboBox1.AddItem vMonths(i)
        
    Next  i

        
    ' Populate years using List property
        Sheet1.ComboBox2.List  =  WorksheetFunction.Transpose(vYears)
    End Sub
    复制代码
    LBound和UBound分别表示了数组的下标和上标,该示例采用了两种不同的方法填充ComboBox,一种是在循环中采用AddItem方法,一种是使用Excel的系统函数Transpose。通过ComboBox.Value可以得到ComboBox的当前值。


 返回目录

 Copy Paste

  1. 1. 利用VBA复制粘贴单元格
    复制代码
    1  Private   Sub  CommandButton1_Click()
    2      Range( " A1 " ).Copy
    3      Range( " A10 " ).Select
    4      ActiveSheet.Paste
    5      Application.CutCopyMode  =   False
    6  End Sub
    复制代码
    示例将A1单元格复制到A10单元格中,Application.CutCopyMode = False用来告诉Excel退出Copy模式,此时被复制的单元格周围活动的虚线将消失。还有一种较为简单的粘贴方式,用ActiveSheet.Paste Destination := Range("A10")代替上例中的3、4行,或者直接用Range("A1").Copy Destination := Range("A10")代替上例中的2、3、4行。
  2. 2. 使用VBA进行单元格复制粘贴的一个例子
    复制代码
    Public   Sub  CopyAreas()
      
    Dim  aRange  As  Range
      
    Dim  Destination  As  Range
      
      
    Set  Destination  =  Worksheets( " Sheet3 " ).Range( " A1 " )
      
    For   Each  aRange  In  Cells.SpecialCells(xlCellTypeConstants, xlNumbers).Areas
        aRange.Copy Destination:
    = Destination
        
    Set  Destination  =  Destination.Offset(aRange.Rows.Count  +   1 )
      
    Next  aRange
    End Sub
    复制代码


 返回目录

 CountA

  1. 1. 返回当前所选区域中非空单元格的数量
    Sub  CountNonBlankCells()              
        
    Dim  myCount  As   Integer                   
        myCount 
    =  Application.CountA(Selection)
        
    MsgBox   " The number of non-blank cell(s) in this selection is :   "   &  myCount, vbInformation,  " Count Cells "
    End Sub
    Count函数返回当前所选区域中的所有单元格数量,而CountA函数则返回当前所选区域中非空单元格的数量。 


 返回目录

 Evaluate

  1. 1. 使用Evaluate函数执行一个公式
    Public   Sub  ConcatenateExample1()
       
    Dim  X  As   String , Y  As   String
       X 
    =   " Jack  "
       Y 
    =   " Smith "
       
    MsgBox  Evaluate( " CONCATENATE("" "   &  X  &   " "","" "   &  Y  &   " "") " )
    End Sub
    Evaluate函数对给定的表达式进行公式运算,如果表达式匹配公式失败则抛出异常。示例中对公式Concatenate进行运算,该公式将给定的多个字符串连接起来。如下面这个例子用来判断当前单元格是否为空:
    复制代码
    Sub  IsActiveCellEmpty()
       
    Dim  stFunctionName  As   String
       
    Dim  stCellReference  As   String
       stFunctionName 
    =   " ISBLANK "
       stCellReference 
    =  ActiveCell.Address
       
    MsgBox  Evaluate(stFunctionName  &   " ( "   &  stCellReference  &   " ) " )
    End Sub
    复制代码


 返回目录

 Excel to XML

  1. 1. 导入XML文件到Excel的一个例子
    复制代码
    Sub  OpenAdoFile() 
        
    Dim  myRecordset  As  ADODB.Recordset 
        
    Dim  objExcel  As  Excel.Application 
        
    Dim  myWorkbook  As  Excel.Workbook 
        
    Dim  myWorksheet  As  Excel.Worksheet 
        
    Dim  StartRange  As  Excel.Range 
        
    Dim  h  as   Integer  

        
    Set  myRecordset  =   New  ADODB.Recordset 

        myRecordset.Open 
    " C:\data.xml " " Provider=MSPersist "  

        
    Set  objExcel  =   New  Excel.Application 
        
    Set  myWorkbook  =  objExcel.Workbooks.Add 
        
    Set  myWorksheet  =  myWorkbook.ActiveSheet 
        objExcel.Visible 
    =   True  
            
    For  h  =   1   To  myRecordset.Fields.Count 
                myWorksheet.Cells(
    1 , h).Value  =  myRecordset.Fields(h  -   1 ).Name 
            
    Next  
        
    Set  StartRange  =  myWorksheet.Cells( 2 1
        StartRange.CopyFromRecordset myRecordset 
        myWorksheet.Range(
    " A1 " ).CurrentRegion.Select 
        myWorksheet.Columns.AutoFit 
        myWorkbook.SaveAs 
    " C:\ExcelReport.xls "  

        
    Set  objExcel  =   Nothing  
        
    Set  myRecordset  =   Nothing  
    End Sub
    复制代码


 返回目录

 Excel ADO

  1. 1. 使用ADO打开Excel
    复制代码
    Sub  Open_ExcelSpread()
       
    Dim  conn  As  ADODB.Connection
       
    Set  conn  =   New  ADODB.Connection
       conn.Open 
    " Provider=Microsoft.Jet.OLEDB.4.0; "   &  _
           
    " Data Source= "   &  CurrentProject.Path  &  _
           
    " \Report.xls; "   &  _
           
    " Extended Properties=Excel 8.0; "
       conn.Close
       
    Set  conn  =   Nothing
    End Sub
    复制代码
  2. 2. 使用SQL语句在用ADO打开的Excel中插入一行数据
    复制代码
    Public   Sub  WorksheetInsert()
      
    Dim  Connection  As  ADODB.Connection
      
    Dim  ConnectionString  As   String
      ConnectionString 
    =   " Provider=Microsoft.Jet.OLEDB.4.0;Data Source= "   &  ThisWorkbook.Path  &   " \Sales.xls; "   &  _
        
    " Extended Properties=Excel 8.0; "
        
      
    Dim  SQL  As   String
        
      SQL 
    =   " INSERT INTO [Sales$] VALUES('VA', 'On', 'Computers', 'Mid', 30) "

      
    Set  Connection  =   New  ADODB.Connection
      
    Call  Connection.Open(ConnectionString)
        
      
    Call  Connection.Execute(SQL, , CommandTypeEnum.adCmdText  Or  ExecuteOptionEnum.adExecuteNoRecords)
      Connection.Close
      
    Set  Connection  =   Nothing
    End Sub
    复制代码
  3. 3. 使用ADO从Access读取数据到Excel
    复制代码
    Public   Sub  SavedQuery()
        
      
    Dim  Field  As  ADODB.Field
      
    Dim  Recordset  As  ADODB.Recordset
      
    Dim  Offset  As   Long
        
      
    Const  ConnectionString  As   String   =   " Provider=Microsoft.Jet.OLEDB.4.0;Data Source=C:\mydb.mdb;Persist Security Info=False "
        
      
    Set  Recordset  =   New  ADODB.Recordset
      
    Call  Recordset.Open( " [Sales By Category] " , ConnectionString, _
        CursorTypeEnum.adOpenForwardOnly, LockTypeEnum.adLockReadOnly, _
        CommandTypeEnum.adCmdTable)

      
    If   Not  Recordset.EOF  Then
        
    With  Sheet1.Range( " A1 " )
          
    For   Each  Field  In  Recordset.Fields
            .Offset(
    0 , Offset).Value  =  Field.Name
            Offset 
    =  Offset  +   1
          
    Next  Field
          .Resize(
    1 , Recordset.Fields.Count).Font.Bold  =   True
        
    End   With
        
    Call  Sheet1.Range( " A2 " ).CopyFromRecordset(Recordset)
        Sheet1.UsedRange.EntireColumn.AutoFit
      
    Else
        Debug.Print 
    " Error: No records returned. "
      
    End   If
      Recordset.Close
      
    Set  Recordset  =   Nothing
    End Sub
    复制代码
    注意其中的CopyFromRecordSet方法,它可以从RecordSet中将数据直接读取到Excel的Range中,这比自己编写代码通过循环去填充Cell值要方便很多。如下面的方法就是通过循环读取值,然后通过Debug语句将读取到的值打印在Immediate窗口中。
    复制代码
    Sub  openWorksheet()
       
    Dim  myConnection  As   New  ADODB.Connection
       
    Dim  myRecordset  As  ADODB.Recordset
       
       myConnection.Open 
    " Provider=Microsoft.Jet.OLEDB.4.0; "   &  _
          
    " Data Source=C:\myCustomers.xls; "   &  _
          
    " Extended Properties=Excel 8.0; "

          
    Set  myRecordset  =   New  ADODB.Recordset
          myRecordset.Open 
    " customers " , myConnection, , , adCmdTable

          
    Do   Until  myRecordset.EOF
             Debug.Print myRecordset(
    " txtNumber " ), myRecordset( " txtBookPurchased " )
             myRecordset.MoveNext
          
    Loop
    End Sub
    复制代码
  4. 4. 将Access中的数据读取到Excel的一个例子
    复制代码
    Sub  ExcelExample()
        
    Dim  r  As   Integer , f  As   Integer
        
    Dim  vrecs  As  Variant
        
    Dim  rs  As  ADODB.Recordset
        
    Dim  cn  As  ADODB.Connection
        
    Dim  fld  As  ADODB.Field
        
    Set  cn  =   New  ADODB.Connection
        cn.Provider 
    =   " Microsoft OLE DB Provider for ODBC Drivers "
        cn.ConnectionString 
    =   " DRIVER={Microsoft Excel Driver (*.xls)};DBQ=C:\mydb.mdb; "
        cn.Open
        Debug.Print cn.ConnectionString
        
    Set  rs  =   New  ADODB.Recordset
        rs.CursorLocation 
    =  adUseClient
        rs.Open 
    " SELECT * FROM Employees " , cn, adOpenDynamic, adLockOptimistic
        
    For   Each  fld  In  rs.Fields
            Debug.Print fld.Name,
        
    Next
        Debug.Print
        vrecs 
    =  rs.GetRows( 6 )
        
    For  r  =   0   To   UBound (vrecs,  1 )
            
    For  f  =   0   To   UBound (vrecs,  2 )
                Debug.Print vrecs(f, r),
            
    Next
            Debug.Print
        
    Next
        Debug.Print 
    " adAddNew:  "   &  rs.Supports(adAddNew)
        Debug.Print 
    " adBookmark:  "   &  rs.Supports(adBookmark)
        Debug.Print 
    " adDelete:  "   &  rs.Supports(adDelete)
        Debug.Print 
    " adFind:  "   &  rs.Supports(adFind)
        Debug.Print 
    " adUpdate:  "   &  rs.Supports(adUpdate)
        Debug.Print 
    " adMovePrevious:  "   &  rs.Supports(adMovePrevious)
        
        rs.Close
        cn.Close
        
    End Sub
    复制代码
    读者可以自行创建测试环境运行这段代码(可根据需要做适当修改),其中程序将各种值打印到Immediate窗口中了。


 返回目录

 Excel to Text File

  1. 1. 使用TextToColumns方法 
    复制代码
    Private   Sub  CommandButton1_Click()
        
    Dim  rg  As  Range
        
    Set  rg  =  ThisWorkbook.Worksheets( " Sheet3 " ).Range( " a20 " ).CurrentRegion
        CSVTextToColumns rg, rg.Offset(
    0 2 )
        
    ' CSVTextToColumns rg
         Set  rg  =   Nothing
    End Sub

    Sub  CSVTextToColumns(rg  As  Range, Optional rgDestination  As  Range)
        
    If  IsMissing(rgDestination)  Or  rgDestination  Is   Nothing   Then
            rg.TextToColumns , xlDelimited, , , , , 
    True
        
    Else
            rg.TextToColumns rgDestination, xlDelimited, , , , , 
    True
        
    End   If
    End Sub
    复制代码
    Range.TextToColumns方法用于将包含文本的一列单元格分解为若干列,有关该方法的详细介绍,读者可以参考Excel的帮助信息,在Excel的帮助信息中搜索TextToColumns即可。示例中的代码将Sheet3中A20单元格所在的当前区域(可以简单地理解为A1:A20的区域)的内容通过TextToColumns方法复制到第三列中,这个由Offset的值决定。如果要演示该示例,读者可以在Excel中创建一个名称为Sheet3的工作表,然后在A1至A20的单元格中输入值,复制代码到Excel VBA工程中,通过按钮触发Click事件。
  2. 2. 导出Range中的数据到文本文件
    复制代码
    Sub  ExportRange()
        FirstCol 
    =   1
        LastCol 
    =   3
        FirstRow 
    =   1
        LastRow 
    =   3
        
        Open ThisWorkbook.Path 
    &   " \textfile.txt "   For  Output  As  # 1
            
    For  r  =  FirstRow  To  LastRow
                
    For  c  =  FirstCol  To  LastCol
                    
    Dim  vData  As  Variant
                    vData 
    =  Cells(r, c).value
                    
    If   IsNumeric (vData)  Then  vData  =  Val(vData)
                    
    If  c  <>  LastCol  Then
                        Write #
    1 , vData;
                    
    Else
                        Write #
    1 , vData
                    
    End   If
                
    Next  c
            
    Next  r
        Close #
    1
    End Sub
    复制代码
  3. 3. 从文本文件导入数据到Excel
    复制代码
    Private   Sub  CommandButton1_Click()
        
    Set  ImpRng  =  ActiveCell
        Open 
    " c:\textfile.txt "   For  Input  As  # 1
        txt 
    =   ""
        Application.ScreenUpdating 
    =   False
        
    Do   While   Not  EOF( 1 )
            Line Input #
    1 , vData
            ImpRng.Value 
    =  vData
            
    Set  ImpRng  =  ImpRng.Offset( 1 0 )
        
    Loop
        Close #
    1
        Application.ScreenUpdating 
    =   True
    End Sub
    复制代码
    示例从c:\textfile.txt文件中按行读取数据并依次显示到当前Sheet的单元格中。


 返回目录

 Excel Toolbar

  1. 通过VBA隐藏Excel中的Toolbars
    复制代码
    Sub  HideAllToolbars()
        
    Dim  TB  As  CommandBar
        
    Dim  TBNum  As   Integer
        
    Dim  mySheet  As  Worksheet
        
    Set  mySheet  =  Sheets( " mySheet " )
        Application.ScreenUpdating 
    =   False

        mySheet.Cells.Clear
        
        TBNum 
    =   0
        
    For   Each  TB In CommandBars
            
    If  TB.Type  =  msoBarTypeNormal  Then
                
    If  TB.Visible  Then
                    TBNum 
    =  TBNum  +   1
                    TB.Visible 
    =   False
                    mySheet.Cells(TBNum, 
    1 =  TB.Name
                
    End   If
            
    End   If
        
    Next  TB
        Application.ScreenUpdating 
    =   True
    End Sub
    复制代码
  2. 2. 通过VBA恢复Excel中的Toolbars
    复制代码
    Sub  RestoreToolbars()
        
    Dim  mySheet  As  Worksheet
        
    Set  mySheet  =  Sheets( " mySheet " )
        Application.ScreenUpdating 
    =   False

        
    On   Error   Resume   Next
        
    For   Each  cell In mySheet.Range( " A:A " ).SpecialCells(xlCellTypeConstants)
            CommandBars(cell.Value).Visible 
    =   True
        
    Next  cell
        Application.ScreenUpdating 
    =   True
    End Sub
    复制代码


 返回目录


你可能感兴趣的:(VBA在Excel中的应用(四))