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

   

 返回目录