目录 Column ComboBox Copy Paste CountA Evaluate Excel to XML Excel ADO Excel to Text File Excel Toolbar
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
|