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