VBA在Excel中的应用（四）

最新推荐文章于 2022-09-06 07:52:26 发布

kendyhj9999

最新推荐文章于 2022-09-06 07:52:26 发布

阅读量1.2k

点赞数

分类专栏： VBA

VBA 专栏收录该内容

18 篇文章

订阅专栏

本文介绍了一系列VBA在Excel中的应用技巧，包括选择整列、列名转换、数组赋值、ComboBox填充、单元格复制粘贴、使用ADO与SQL操作Excel数据等。涵盖了从基础操作到高级应用的广泛内容。

摘要生成于 C知道，由 DeepSeek-R1 满血版支持，前往体验 >

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

选择整列

Sub SelectEntireColumn()
Selection.EntireColumn.Select
End Sub

. 将指定的列序号转换为列名

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。

将数组直接赋值给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

填充数据到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的当前值。

利用VBA复制粘贴单元格

Private Sub CommandButton1_Click()
     Range("A1").Copy
     Range("A10").Select
     ActiveSheet.Paste
     Application.CutCopyMode = False
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行。

使用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

返回当前所选区域中非空单元格的数量

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函数执行一个公式

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

导入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

使用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

使用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

使用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

将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

使用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事件

导出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

从文本文件导入数据到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

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

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