Excel 2003 實用技巧

發佈日期 : 1/31/2005 | 更新日期 : 1/31/2005

Frank Rice
Microsoft Corporation

適用於：
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

返回頁首

將字符附加到單元格值

以下程序可搜索選中的列，並將一個字符（在此示例中爲撇號）附加到每個條目的開頭。如果您已經選定了範圍，並且沒有聲明 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) 代碼。通過使用這些程序以及對它們進行修改以滿足您自己的使用所需，可以使自己的應用程序更加健壯，併爲您的用戶提供更多的選擇。

返回頁首

其他資源

下面是幫助您進行 Excel 開發的其他資源列表：

轉到原英文頁面

返回頁首

Excel 2003 實用技巧 (FROM MSDN)

Excel 2003 實用技巧

本頁內容

簡介

隔頁打印工作表

使用 ADO 在工作簿中檢索工作表名稱

將搜索結果顯示在單獨的頁中

刪除單元格的一部分

從工作表中刪除空行和嵌入的字段名稱

創建數據的主列表

根據值插入行

將文本轉換爲電子郵件地址

根據單元格值處理字體顏色

將字符附加到單元格值

小結

其他資源

第３回 Elasticsearch 入門ドキュメント管理は意外と高度なことができる

[轉載]Swift多線程編程總結

Excel 2003 實用技巧 (FROM MSDN)

使用 Excel 2003 對象模型添加 XML 數據集成 (From MSDN)

從 .NET 開發人員的角度理解 Excel 對象模型 (From MSDN)

https://yachay.unat.edu.pe/blog/index.php?comment_area=format_blog&comment_component=blog&comment_co

linux以太網驅動總結