Excel 2003 实用技巧 [转自 MSDN]

admin

适用于：
Microsoft Office Excel 2003

摘要：查找使用 Microsoft Excel 进行开发的技巧，它们是从各种 Microsoft Excel 新闻组汇集而来的。通过使用这些程序以及对它们进行修改以满足您自己的使用所需，可以使自己的应用程序更健壮，并为您的用户提供更多的选择。



本页内容
简介
隔页打印工作表
使用 ADO 在工作簿中检索工作表名称
将搜索结果显示在单独的页中
删除单元格的一部分
从工作表中删除空行和嵌入的字段名称
创建数据的主列表
根据值插入行
将文本转换为电子邮件地址
根据单元格值处理字体颜色
将字符附加到单元格值
小结


简介
本文介绍了使用 Microsoft Office Excel 2003 的 技巧，它们是从各种新闻组汇集而来的。对于那些不熟悉的人来说，新闻组是一个论坛，用户和开发人员可以在这里提交涉及许多技术主题（例如 Office 应用程序）的问题。用户和其他专业人员可以回答这些问题。在此上下文中，新闻组包含大量经过修改的信息，可以帮助您使用和开发所选的 Office 应用程序。构成这些技巧的答案都是超级用户和开发人员（称为 Microsoft 最有价值的专家 (MVP)）多年经验的结晶。有关新闻组的更多信息，可以在新闻组帮助站点中找到。

本文中的代码示例旨在作为您自定义应用程序的起点。这些示例已在 Excel 2003 上经过测试，但是也可以在 Excel 的先前版本中运行。在您的应用程序中使用这些示例之前，应该在您自己的 Excel 版本中对它们进行测试。
隔页打印工作表

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

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”），则代码就会删除该行，然后移到下一行进行检查。

Sub CleanUp()
    On Error Resume Next

    With ActiveSheet
        'Change the column value to suit your needs.
        LastRw = .Cells(Rows.Count, "A").End(xlUp).Row
        Set Rng1 = .Range(Cells(1, "A"), Cells(LastRw, "A"))
        Set Rng2 = .Range(Cells(2, "A"), Cells(LastRw, "A"))
    End With

    With Rng1
        .SpecialCells(xlCellTypeBlanks).EntireRow.Delete
        .AutoFilter Field:=1, Criteria1:="Hello"
        Rng2.SpecialCells(xlCellTypeVisible).EntireRow.Delete
       .AutoFilter
End With
End Sub



创建数据的主列表
该代码通过将工作表中的信息拼凑在一起来创建一个主列表。此示例创建了一个“Master”工作表，搜索列直到遇到一个空单元格，再将扫描数据复制到该 Master 工作表中，然后继续搜索下一个空单元格。

Sub CopyData()
    Dim i As Long, rng As Range, sh As Worksheet
    'Change these worksheet names as needed.
    Worksheets.Add(After:=Worksheets( _
       Worksheets.Count)).Name = "Master"
    Set sh = Worksheets("Input-Sales")
    i = 1
    Do While Not IsEmpty(sh.Cells(i, 1))
        Set rng = Union(sh.Cells(i, 1), _
           sh.Cells(i + 2, 1).Resize(3, 1))
        rng.EntireRow.Copy Destination:= _
           Worksheets("Master").Cells(Rows.Count, 1).End(xlUp)
        i = i + 16
    Loop
End Sub



根据值插入行
该示例可在某一列中搜索某个值，当找到该值时，就插入一个空行。此程序可在 B 列中搜索值“1”，当找到该值时，就插入一个空行。

Sub InsertRow()
    Dim Rng As Range
    Dim findstring As String
    'Change the search string to suit your needs.
    findstring = "1"
    'Change the range to suit your needs.
    Set Rng = Range("B:B").Find(What:=findstring, LookAt:=xlWhole)
    While Not (Rng Is Nothing)
        Rng.EntireRow.Insert
        Set Rng = Range("B" & Rng.Row + 1 & ":B" & Rows.Count) _
            .Find(What:=findstring, LookAt:=xlWhole)
    Wend
End Sub



将文本转换为电子邮件地址
以下代码可循环访问一列范围数据，并将每个条目转换为一个电子邮件地址。

Sub convertToEmail()
    Dim convertRng As Range
    'Change the range to suit your need.
    Set convertRng = Range("B13:B16")
    Dim rng As Range

    For Each rng In convertRng
        If rng.Value <> "" Then
            ActiveSheet.Hyperlinks.Add rng, "mailto:" & rng.Value
        End If
    Next rng

End Sub



根据单元格值处理字体颜色
下面的示例可根据单元格中显示的值将单元格的字体设置为某种颜色。具体来说，如果单元格包含公式（例如“=today()”），则设置为黑色，如果单元格包含数据（例如“30 Oct 2004”），则设置为蓝色。

Sub ColorCells()
    On Error Resume Next
    With Sheet1.UsedRange
        .SpecialCells(xlCellTypeFormulas).Font.Color = vbBlack
        .SpecialCells(xlCellTypeConstants).Font.Color = vbBlue
    End With
    On Error GoTo 0
End Sub

前面的示例可更改工作表的整个使用范围的字体颜色。以下代码片段使用 Range 对象的 HasFormula 属性来确定一个单元格是否包含公式：

Sub ColorCells2()
    With Sheet1.Range("A3")
        If .HasFormula Then
            .Font.Color = vbBlack
        Else
            .Font.Color = vbBlue
        End If
    End With
End Sub

或

Sub ColorCells3()
    With Cells(3, 3)
        .Interior.Color = IIf(.HasFormula, vbBlue, vbBlack)
    End With
End Sub



根据单元格值处理字体颜色
下面的示例可根据单元格中显示的值将单元格的字体设置为某种颜色。具体来说，如果单元格包含公式（例如“=today()”），则设置为黑色，如果单元格包含数据（例如“30 Oct 2004”），则设置为蓝色。

Sub ColorCells()
    On Error Resume Next
    With Sheet1.UsedRange
        .SpecialCells(xlCellTypeFormulas).Font.Color = vbBlack
        .SpecialCells(xlCellTypeConstants).Font.Color = vbBlue
    End With
    On Error GoTo 0
End Sub

前面的示例可更改工作表的整个使用范围的字体颜色。以下代码片段使用 Range 对象的 HasFormula 属性来确定一个单元格是否包含公式：

Sub ColorCells2()
    With Sheet1.Range("A3")
        If .HasFormula Then
            .Font.Color = vbBlack
        Else
            .Font.Color = vbBlue
        End If
    End With
End Sub

或

Sub ColorCells3()
    With Cells(3, 3)
        .Interior.Color = IIf(.HasFormula, vbBlue, vbBlack)
    End With
End Sub



根据单元格值处理字体颜色
下面的示例可根据单元格中显示的值将单元格的字体设置为某种颜色。具体来说，如果单元格包含公式（例如“=today()”），则设置为黑色，如果单元格包含数据（例如“30 Oct 2004”），则设置为蓝色。

Sub ColorCells()
    On Error Resume Next
    With Sheet1.UsedRange
        .SpecialCells(xlCellTypeFormulas).Font.Color = vbBlack
        .SpecialCells(xlCellTypeConstants).Font.Color = vbBlue
    End With
    On Error GoTo 0
End Sub

前面的示例可更改工作表的整个使用范围的字体颜色。以下代码片段使用 Range 对象的 HasFormula 属性来确定一个单元格是否包含公式：

Sub ColorCells2()
    With Sheet1.Range("A3")
        If .HasFormula Then
            .Font.Color = vbBlack
        Else
            .Font.Color = vbBlue
        End If
    End With
End Sub

或

Sub ColorCells3()
    With Cells(3, 3)
        .Interior.Color = IIf(.HasFormula, vbBlue, vbBlack)
    End With
End Sub



将字符附加到单元格值
以下程序可搜索选中的列，并将一个字符（在此示例中为撇号）附加到每个条目的开头。如果您已经选定了范围，并且没有声明 Option Explicit，则代码会如示例所示运行。如果只选择了一个单元格，那么代码仅在活动单元格中操作。

Sub AddApostrophe()
    Dim cell as Range
    for each cell in Selection
        if not cell.hasformula then
            if not isempty(cell) then
                cell.Value  = "'" & cell.Value
            End if
        end if
    Next
End sub

上述代码的变体只将字符（撇号）放在数字单元格中。该代码只在所选的数字单元格中操作。

Sub AddApostrophe()
    Dim cell as Range
    for each cell in Selection
        if not cell.hasformula then
            if not isempty(cell) then
                if isnumeric(cell) then
                    'Change the character as needed.
                    cell.Value  = "'" & cell.Value
                end if
            End if
        end if
    Next
End sub



小结
本文介绍了可在 Excel 中使用的许多技巧和 Microsoft Visual Basic for Applications (VBA) 代码。通过使用这些程序以及对它们进行修改以满足您自己的使用所需，可以使自己的应用程序更加健壮，并为您的用户提供更多的选择。

fishpenguin

谢谢，在哪里可以输入这些代码实现这些功能啊？

pucx

不错  谢谢楼主分享