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


 返回目录

posted @ 2023-04-15 23:17  快乐58  阅读(167)  评论(0)    收藏  举报