目录
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. 将指定的列序号转换为列名
如columnIndex为11则转换后的列名为K，columnIndex为111则转换后的列名为DG。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
- 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()又如Range("C1").ColumnWidth = Range("A1").ColumnWidth
ActiveCell.ColumnWidth = 20
End Sub - 5. 清除Columns的内容
Sub clear()这将导致当前Sheet中所有的内容被清除，等同于Cells.Clear，如果要清除特定列中的内容，可以给Columns加上参数。其它相关的还有Columns.ClearContents，Columns.ClearFormats，Columns.AutoFit，Columns.NumberFormat = "0.00%"等，与Cells对象中提供的诸多方法相似。
Columns.clear
End Sub
返回目录ComboBox
- 1. 填充数据到ComboBox
LBound和UBound分别表示了数组的下标和上标，该示例采用了两种不同的方法填充ComboBox，一种是在循环中采用AddItem方法，一种是使用Excel的系统函数Transpose。通过ComboBox.Value可以得到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
Copy Paste
- 1. 利用VBA复制粘贴单元格
示例将A1单元格复制到A10单元格中，Application.CutCopyMode = False用来告诉Excel退出Copy模式，此时被复制的单元格周围活动的虚线将消失。还有一种较为简单的粘贴方式，用ActiveSheet.Paste Destination := Range("A10")代替上例中的3、4行，或者直接用Range("A1").Copy Destination := Range("A10")代替上例中的2、3、4行。1 Private Sub CommandButton1_Click()
2 Range( " A1 " ).Copy
3 Range( " A10 " ).Select
4 ActiveSheet.Paste
5 Application.CutCopyMode = False
6 End Sub
- 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()Count函数返回当前所选区域中的所有单元格数量，而CountA函数则返回当前所选区域中非空单元格的数量。
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
Evaluate
- 1. 使用Evaluate函数执行一个公式
Evaluate函数对给定的表达式进行公式运算，如果表达式匹配公式失败则抛出异常。示例中对公式Concatenate进行运算，该公式将给定的多个字符串连接起来。如下面这个例子用来判断当前单元格是否为空：Public Sub ConcatenateExample1()
Dim X As String , Y As String
X = " Jack "
Y = " Smith "
MsgBox Evaluate( " CONCATENATE("" " & X & " "","" " & Y & " "") " )
End Sub
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
注意其中的CopyFromRecordSet方法，它可以从RecordSet中将数据直接读取到Excel的Range中，这比自己编写代码通过循环去填充Cell值要方便很多。如下面的方法就是通过循环读取值，然后通过Debug语句将读取到的值打印在Immediate窗口中。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
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的一个例子
读者可以自行创建测试环境运行这段代码（可根据需要做适当修改），其中程序将各种值打印到Immediate窗口中了。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
Excel to Text File
- 1. 使用TextToColumns方法
Range.TextToColumns方法用于将包含文本的一列单元格分解为若干列，有关该方法的详细介绍，读者可以参考Excel的帮助信息，在Excel的帮助信息中搜索TextToColumns即可。示例中的代码将Sheet3中A20单元格所在的当前区域（可以简单地理解为A1:A20的区域）的内容通过TextToColumns方法复制到第三列中，这个由Offset的值决定。如果要演示该示例，读者可以在Excel中创建一个名称为Sheet3的工作表，然后在A1至A20的单元格中输入值，复制代码到Excel VBA工程中，通过按钮触发Click事件。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
- 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
示例从c:\textfile.txt文件中按行读取数据并依次显示到当前Sheet的单元格中。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
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
本文转自Jaxu博客园博客，原文链接：http://www.cnblogs.com/jaxu/archive/2009/07/17/1525571.html，如需转载请自行联系原作者
