Excel 2003 中很实用的几个VBA技巧

Excel 2003 中很实用的几个VBA技巧 目录 ============================================================= 隔页打印工作表............................................................................................................ 1 使用 ADO 在工作簿中检索工作表名称 ................................................................... 2 将搜索结果显示在单独的页中.................................................................................... 3 删除单元格的一部分.................................................................................................... 4 从工作表中删除空行和嵌入的字段名称.................................................................... 4 创建数据的主列表........................................................................................................ 5 根据值插入行................................................................................................................ 5 将文本转换为电子邮件地址........................................................................................ 6 根据单元格值处理字体颜色........................................................................................ 6 将字符附加到单元格值................................................................................................ 7 =============================================================

隔页打印工作表 本部分中的代码用于隔页打印工作簿中的工作表。它通过循环访问所有的工作表并用偶数表填充数组来做到这一点。

Sub PrintEvenSheets() Dim mySheetNames() As String Dim iCtr As Long Dim wCtr As Long

iCtr = 0 For wCtr = 1 To Sheets.Count If wCtr Mod 2 = 0 Then iCtr = iCtr + 1 ReDim Preserve mySheetNames(1 To iCtr) mySheetNames(iCtr) = Sheets(wCtr).Name End If Next wCtr

If iCtr = 0 Then 'Only one sheet. Display message or do nothing. Else Sheets(mySheetNames).PrintOut preview:=True End If

End Sub 该示例用于打印偶数工作表。您可以循环访问所有的工作表，并根据要打印的偶数工作表来构建一个数组。可以通过删除本示例中的第一个 If...Then End If 语句来做到这一点。

使用 ADO 在工作簿中检索工作表名称 此代码示例使用 Microsoft ActiveX Data Objects (ADO) 在工作簿中检索工作表的名称。通过使用 ADO，您可以在 Excel 之外处理文件。ADO 使用通用编程模型来访问许多窗体中的数据。有关 ADO 的更多信息，请参阅 ADO Programmer's Guide。

Sub GetSheetNames() Dim objConn As Object Dim objCat As Object Dim tbl As Object Dim iRow As Long Dim sWorkbook As String Dim sConnString As String Dim sTableName As String Dim cLength As Integer Dim iTestPos As Integer Dim iStartpos As Integer

'Change the path to suit your own needs. sWorkbook = "c:\myDir\Book1.xls" sConnString = "Provider=Microsoft.Jet.OLEDB.4.0;" & _ "Data Source=" & sWorkbook & ";" & _ "Extended Properties=Excel 8.0;"

Set objConn = CreateObject("ADODB.Connection") objConn.Open sConnString Set objCat = CreateObject("ADOX.Catalog") Set objCat.ActiveConnection = objConn

iRow = 1 For Each tbl In objCat.Tables sTableName = tbl.Name cLength = Len(sTableName) iTestPos = 0 iStartpos = 1 'Worksheet names with embedded spaces are enclosed 'by single quotes. If Left(sTableName, 1) = "'" And Right(sTableName, 1) = "'" Then iTestPos = 1 iStartpos = 2 End If 'Worksheet names always end in the "$" character. If Mid$(sTableName, cLength - iTestPos, 1) = "$" Then Cells(iRow, 1) = Mid$(sTableName, iStartpos, cLength - _ (iStartpos + iTestPos)) MsgBox Cells(iRow, 1) iRow = iRow + 1 End If Next tbl objConn.Close Set objCat = Nothing Set objConn = Nothing

End Sub

将搜索结果显示在单独的页中 该代码示例在工作表的列中搜索单词 (“Hello”)。一旦找到匹配的数据，就将其复制到另一个工作表（“Search Results”）中。

Sub FindMe() Dim intS As Integer Dim rngC As Range Dim strToFind As String, FirstAddress As String Dim wSht As Worksheet

Application.ScreenUpdating = False intS = 1 'This step assumes that you have a worksheet named 'Search Results. Set wSht = Worksheets("Search Results") strToFind = "Hello"

'Change this range to suit your own needs. With ActiveSheet.Range("A1:C2000") Set rngC = .Find(what:=strToFind, LookAt:=xlPart) If Not rngC Is Nothing Then FirstAddress = rngC.Address Do rngC.EntireRow.Copy wSht.Cells(intS, 1) intS = intS + 1 Set rngC = .FindNext(rngC) Loop While Not rngC Is Nothing And rngC.Address <> FirstAddress End If End With

End Sub

删除单元格的一部分 该程序搜索字符串值的范围，并删除单元格的一部分内容。在本例中，当字符“Y”或“N”通过一个或多个空格与文本正文分隔时，程序就会从该字符串中删除它。

Sub RemoveString() Dim sStr as String, cell as Range 'Change the worksheet and column values to suit your needs. For Each cell In Range("Sheet1!F:F") If cell.Value = "" Then Exit Sub sStr = Trim(Cell.Value) If Right(sStr, 3) = " Y" Or Right(sStr, 3) = " N" Then cell.Value = Left(sStr, Len(sStr) - 1) End If Next End Sub

To remove the trailing spaces left by removing the Y or N, change: cell.Value = Left(sStr, Len(sStr) - 1)

to cell.Value = Trim(Left(sStr, Len(sStr) - 1))

从工作表中删除空行和嵌入的字段名称 该示例可搜索一列数据的内容。如果单元格为空或者包含一个特定的单元格值（在此示例中为“Hello”），则代码就会删除该行，然后移到下一行进行检查。