VBA在Excel中的应用（四）

当前位置:

首页 > 编程开发 > vb >

VBA在Excel中的应用（四）

Column

1. 选择整列
Sub SelectEntireColumn()
Selection.EntireColumn.Select
End Sub
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. 将数组直接赋值给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. 指定Column的宽度
Sub colDemo()
ActiveCell.ColumnWidth = 20
End Sub
又如Range("C1").ColumnWidth = Range("A1").ColumnWidth
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. 填充数据到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. 利用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. 使用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. 返回当前所选区域中非空单元格的数量
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. 使用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. 导入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. 使用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. 使用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. 使用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. 将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. 使用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. 导出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. 从文本文件导入数据到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

通过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. 通过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

出处：https://www.cnblogs.com/jaxu/archive/2009/07/17/1525571.html

栏目列表