VBA在Excel中的应用（四）

目录

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复制粘贴单元格
    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

返回目录