Excel 2003 實(shí)用技巧 [轉(zhuǎn)自 MSDN]

適用于：
Microsoft Office Excel 2003

摘要：查找使用 Microsoft Excel 進(jìn)行開(kāi)發(fā)的技巧，它們是從各種 Microsoft Excel 新聞組匯集而來(lái)的。通過(guò)使用這些程序以及對(duì)它們進(jìn)行修改以滿(mǎn)足您自己的使用所需，可以使自己的應(yīng)用程序更健壯，并為您的用戶(hù)提供更多的選擇。



本頁(yè)內(nèi)容
簡(jiǎn)介
隔頁(yè)打印工作表
使用 ADO 在工作簿中檢索工作表名稱(chēng)
將搜索結(jié)果顯示在單獨(dú)的頁(yè)中
刪除單元格的一部分
從工作表中刪除空行和嵌入的字段名稱(chēng)
創(chuàng)建數(shù)據(jù)的主列表
根據(jù)值插入行
將文本轉(zhuǎn)換為電子郵件地址
根據(jù)單元格值處理字體顏色
將字符附加到單元格值
小結(jié)


簡(jiǎn)介
本文介紹了使用 Microsoft Office Excel 2003 的 技巧，它們是從各種新聞組匯集而來(lái)的。對(duì)于那些不熟悉的人來(lái)說(shuō)，新聞組是一個(gè)論壇，用戶(hù)和開(kāi)發(fā)人員可以在這里提交涉及許多技術(shù)主題（例如 Office 應(yīng)用程序）的問(wèn)題。用戶(hù)和其他專(zhuān)業(yè)人員可以回答這些問(wèn)題。在此上下文中，新聞組包含大量經(jīng)過(guò)修改的信息，可以幫助您使用和開(kāi)發(fā)所選的 Office 應(yīng)用程序。構(gòu)成這些技巧的答案都是超級(jí)用戶(hù)和開(kāi)發(fā)人員（稱(chēng)為 Microsoft 最有價(jià)值的專(zhuān)家 (MVP)）多年經(jīng)驗(yàn)的結(jié)晶。有關(guān)新聞組的更多信息，可以在新聞組幫助站點(diǎn)中找到。

本文中的代碼示例旨在作為您自定義應(yīng)用程序的起點(diǎn)。這些示例已在 Excel 2003 上經(jīng)過(guò)測(cè)試，但是也可以在 Excel 的先前版本中運(yùn)行。在您的應(yīng)用程序中使用這些示例之前，應(yīng)該在您自己的 Excel 版本中對(duì)它們進(jìn)行測(cè)試。
隔頁(yè)打印工作表

本部分中的代碼用于隔頁(yè)打印工作簿中的工作表。它通過(guò)循環(huán)訪(fǎng)問(wèn)所有的工作表并用偶數(shù)表填充數(shù)組來(lái)做到這一點(diǎn)。

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

該示例用于打印偶數(shù)工作表。您可以循環(huán)訪(fǎng)問(wèn)所有的工作表，并根據(jù)要打印的偶數(shù)工作表來(lái)構(gòu)建一個(gè)數(shù)組。可以通過(guò)刪除本示例中的第一個(gè) If...Then End If 語(yǔ)句來(lái)做到這一點(diǎn)。


使用 ADO 在工作簿中檢索工作表名稱(chēng)
此代碼示例使用 Microsoft ActiveX Data Objects (ADO) 在工作簿中檢索工作表的名稱(chēng)。通過(guò)使用 ADO，您可以在 Excel 之外處理文件。ADO 使用通用編程模型來(lái)訪(fǎng)問(wèn)許多窗體中的數(shù)據(jù)。有關(guān) ADO 的更多信息，請(qǐng)參閱 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


將搜索結(jié)果顯示在單獨(dú)的頁(yè)中

該代碼示例在工作表的列中搜索單詞 (“Hello”)。一旦找到匹配的數(shù)據(jù)，就將其復(fù)制到另一個(gè)工作表（“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


刪除單元格的一部分
該程序搜索字符串值的范圍，并刪除單元格的一部分內(nèi)容。在本例中，當(dāng)字符“Y”或“N”通過(guò)一個(gè)或多個(gè)空格與文本正文分隔時(shí)，程序就會(huì)從該字符串中刪除它。

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))



從工作表中刪除空行和嵌入的字段名稱(chēng)
該示例可搜索一列數(shù)據(jù)的內(nèi)容。如果單元格為空或者包含一個(gè)特定的單元格值（在此示例中為“Hello”），則代碼就會(huì)刪除該行，然后移到下一行進(jìn)行檢查。

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



創(chuàng)建數(shù)據(jù)的主列表
該代碼通過(guò)將工作表中的信息拼湊在一起來(lái)創(chuàng)建一個(gè)主列表。此示例創(chuàng)建了一個(gè)“Master”工作表，搜索列直到遇到一個(gè)空單元格，再將掃描數(shù)據(jù)復(fù)制到該 Master 工作表中，然后繼續(xù)搜索下一個(gè)空單元格。

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



根據(jù)值插入行
該示例可在某一列中搜索某個(gè)值，當(dāng)找到該值時(shí)，就插入一個(gè)空行。此程序可在 B 列中搜索值“1”，當(dāng)找到該值時(shí)，就插入一個(gè)空行。

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



將文本轉(zhuǎn)換為電子郵件地址
以下代碼可循環(huán)訪(fǎng)問(wèn)一列范圍數(shù)據(jù)，并將每個(gè)條目轉(zhuǎn)換為一個(gè)電子郵件地址。

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



根據(jù)單元格值處理字體顏色
下面的示例可根據(jù)單元格中顯示的值將單元格的字體設(shè)置為某種顏色。具體來(lái)說(shuō)，如果單元格包含公式（例如“=today()”），則設(shè)置為黑色，如果單元格包含數(shù)據(jù)（例如“30 Oct 2004”），則設(shè)置為藍(lán)色。

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

前面的示例可更改工作表的整個(gè)使用范圍的字體顏色。以下代碼片段使用 Range 對(duì)象的 HasFormula 屬性來(lái)確定一個(gè)單元格是否包含公式：

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



根據(jù)單元格值處理字體顏色
下面的示例可根據(jù)單元格中顯示的值將單元格的字體設(shè)置為某種顏色。具體來(lái)說(shuō)，如果單元格包含公式（例如“=today()”），則設(shè)置為黑色，如果單元格包含數(shù)據(jù)（例如“30 Oct 2004”），則設(shè)置為藍(lán)色。

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

前面的示例可更改工作表的整個(gè)使用范圍的字體顏色。以下代碼片段使用 Range 對(duì)象的 HasFormula 屬性來(lái)確定一個(gè)單元格是否包含公式：

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



根據(jù)單元格值處理字體顏色
下面的示例可根據(jù)單元格中顯示的值將單元格的字體設(shè)置為某種顏色。具體來(lái)說(shuō)，如果單元格包含公式（例如“=today()”），則設(shè)置為黑色，如果單元格包含數(shù)據(jù)（例如“30 Oct 2004”），則設(shè)置為藍(lán)色。

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

前面的示例可更改工作表的整個(gè)使用范圍的字體顏色。以下代碼片段使用 Range 對(duì)象的 HasFormula 屬性來(lái)確定一個(gè)單元格是否包含公式：

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



將字符附加到單元格值
以下程序可搜索選中的列，并將一個(gè)字符（在此示例中為撇號(hào)）附加到每個(gè)條目的開(kāi)頭。如果您已經(jīng)選定了范圍，并且沒(méi)有聲明 Option Explicit，則代碼會(huì)如示例所示運(yùn)行。如果只選擇了一個(gè)單元格，那么代碼僅在活動(dòng)單元格中操作。

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

上述代碼的變體只將字符（撇號(hào)）放在數(shù)字單元格中。該代碼只在所選的數(shù)字單元格中操作。

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



小結(jié)
本文介紹了可在 Excel 中使用的許多技巧和 Microsoft Visual Basic for Applications (VBA) 代碼。通過(guò)使用這些程序以及對(duì)它們進(jìn)行修改以滿(mǎn)足您自己的使用所需，可以使自己的應(yīng)用程序更加健壯，并為您的用戶(hù)提供更多的選擇。