[建议分享到PC端, 打开链接, 复制到PC上测试运行]
续接...... Range对象之Find方法应用(1)
5. 综合示例
[示例1]查找值并选中该值所在的单元格
[示例1-1]
Sub Find_First()
Dim FindString As String
Dim rng As Range
FindString = InputBox("请输入要查找的值:")
If Trim(FindString) <> "" Then
With Sheets("Sheet1").Range("A:A")
Set rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
Application.Goto rng, True
Else
MsgBox "没有找到!"
End If
End With
End If
End Sub
示 例说明：运行程序后，将在工作表Sheet1的A列中查找InputBox函数输入框中所输入的值，并查找该值所在的第一个单元格，如果没有找到该值，则 显示消息框“没有找到!”。语句Application.Goto rng, True的作用是将窗口滚动至该单元格，即该单元格位于当前窗口的左上方。
[示例1-2]
Sub Find_Last()
Dim FindString As String
Dim rng As Range
FindString = InputBox("请输入要查找的值")
If Trim(FindString) <> "" Then
With Sheets("Sheet1").Range("A:A")
Set rng = .Find(What:=FindString, _
After:=.Cells(1), _
LookIn:=xlValues, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False)
If Not rng Is Nothing Then
Application.Goto rng, True
Else
MsgBox "Nothing found"
End If
End With
End If
End Sub
示例说明：与上面的程序不同的是，运行该程序后，将在工作表Sheet1的A列中查找InputBox函数输入框中所输入的值，并选中该值所在的最后一个单元格。请比较代码中Find方法的参数。
[示例1-3]
Sub Find_Todays_Date()
Dim FindString As Date
Dim rng As Range
FindString = Date
With Sheets("Sheet1").Range("A:A")
Set rng = .Find(What:=FindString, _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not rng Is Nothing Then
Application.Goto rng, True
Else
MsgBox "没有找到!"
End If
End With
End Sub
示例说明：运行程序后，将在工作表Sheet1的A列中查找日期所在的单元格，并选中第一个日期单元格。
[示例2]在B列中标出A列中有相应值的单元格
Sub Mark_cells_in_column()
Dim FirstAddress As String
Dim myArr As Variant
Dim rng As Range
Dim I As Long
Application.ScreenUpdating = False
myArr = Array("VBA")
'也能够在数组中使用更多的值,如下所示
'myArr = Array("VBA", "VSTO")
With Sheets("Sheet2").Range("A:A")
.Offset(0, 1).ClearContents
'清除右侧单元格中的内容
For I = LBound(myArr) To UBound(myArr)
Set rng = .Find(What:=myArr(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'如要想查找rng.value中的一部分,可使用参数值xlPart
'如果使用LookIn:=xlValues,也会处理公式单元格中与条件相同的值
If Not rng Is Nothing Then
FirstAddress = rng.Address
Do
rng.Offset(0, 1).Value = "X"
'如果值VBA找到,则在该单元格的右侧列中的相应单元格作上标记
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> FirstAddress
End If
Next I
End With
Application.ScreenUpdating = True
End Sub
示例说明：运行程序后，将查找工作表Sheet2上A列中的每个单元格，并在值为“VBA”所在的单元格的右侧单元格中作出标记“X”。
[示例3]为区域中指定值的单元格填充颜色
Sub Color_cells_in_Range()
Dim FirstAddress As String
Dim MySearch As Variant
Dim myColor As Variant
Dim rng As Range
Dim I As Long
MySearch = Array("VBA")
myColor = Array("3")
'也能在数组中使用多个值
'MySearch = Array("VBA", "Hello", "OK")
'myColor = Array("3", "6", "10")
With Sheets("Sheet3").Range("A1:C4")
'将所有单元格中的填充色改为无填充色
.Interior.ColorIndex = xlColorIndexNone
For I = LBound(MySearch) To UBound(MySearch)
Set rng = .Find(What:=MySearch(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'如果想查找rng.value的一部分,则使用参数值xlPart
'如果使用LookIn:=xlValues,则也会处理公式单元格
If Not rng Is Nothing Then
FirstAddress = rng.Address
Do
rng.Interior.ColorIndex = myColor(I)
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> FirstAddress
End If
Next I
End With
End Sub
示例说明：运行程序后，将在工作表Sheet3上的单元格区域A1：C4中查找含有“VBA”的单元格，并将这些单元格填充为红色。如示例中的注释所提示的，也可以使用数组，将不同的值所在的单元格标记为不同的颜色。
也可以添加下面的语句，改变单元格中文本的颜色：
.Font.ColorIndex=0 .Font.ColorIndex=myColor(I)
[示例4]为工作表中指定值的单元格填充颜色
Sub Color_cells_in_Sheet()
Dim FirstAddress As String
Dim MySearch As Variant
Dim myColor As Variant
Dim rng As Range
Dim I As Long
MySearch = Array("VBA")
myColor = Array("3")
'也能在数组中使用多个值
'MySearch = Array("VBA", "Hello", "OK")
'myColor = Array("3", "6", "10")
With Sheets("Sheet4").Cells
'将所有单元格中的填充色改为无填充色
.Interior.ColorIndex = xlColorIndexNone
For I = LBound(MySearch) To UBound(MySearch)
Set rng = .Find(What:=MySearch(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'如果想查找rng.value的一部分,则使用参数值xlPart
'如果使用LookIn:=xlValues,则也会处理公式单元格
If Not rng Is Nothing Then
FirstAddress = rng.Address
Do
rng.Interior.ColorIndex = myColor(I)
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> FirstAddress
End If
Next I
End With
End Sub
示例说明：运行程序后，将在工作表Sheet4中查找含有“VBA”的单元格，并将这些单元格填充为红色。如示例中的注释所提示的，也可以使用数组，将不同的值所在的单元格标记为不同的颜色。
也可以添加下面的语句，改变单元格中文本的颜色：
.Font.ColorIndex=0 .Font.ColorIndex=myColor(I)
[示例5]为工作簿所有工作表中含有指定值的单元格填充颜色
Sub Color_cells_in_All_Sheets()
Dim FirstAddress As String
Dim MySearch As Variant
Dim myColor As Variant
Dim sh As Worksheet
Dim rng As Range
Dim I As Long
MySearch = Array("ron")
myColor = Array("3")
'也能在数组中使用多个值
'MySearch = Array("VBA", "Hello", "OK")
'myColor = Array("3", "6", "10")
For Each sh In ActiveWorkbook.Worksheets
With sh.Cells
'将所有单元格中的填充色改为无填充色
.Interior.ColorIndex = xlColorIndexNone
For I = LBound(MySearch) To UBound(MySearch)
Set rng = .Find(What:=MySearch(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlWhole, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
'如果想查找rng.value的一部分,则使用参数值xlPart
'如果使用LookIn:=xlValues,则也会处理公式单元格
If Not rng Is Nothing Then
FirstAddress = rng.Address
Do
rng.Interior.ColorIndex = myColor(I)
Set rng = .FindNext(rng)
Loop While Not rng Is Nothing And rng.Address <> FirstAddress
End If
Next I
End With
Next sh
End Sub
示例说明：运行程序后，将在工作簿所有工作表中查找含有“VBA”的单元格，并将这些单元格填充为红色。如示例中的注释所提示的，也可以使用数组，将不同的值所在的单元格标记为不同的颜色。
也可以添加下面的语句，改变单元格中文本的颜色：
.Font.ColorIndex=0 .Font.ColorIndex=myColor(I)
[示例6]复制相应的值到另一个工作表中
Sub Copy_To_Another_Sheet()
Dim FirstAddress As String
Dim MyArr As Variant
Dim Rng As Range
Dim Rcount As Long
Dim I As Long
Application.ScreenUpdating = False
'也能够使用含有更多值的数组
'myArr = Array("@", "www")
MyArr = Array("@")
Rcount = 0
With Sheets("Sheet5").Range("A1:E10")
For I = LBound(MyArr) To UBound(MyArr)
'如果使用LookIn:=xlValues,也会处理含有"@"的公式单元格
'注意:本示例使用xlPart而不是xlWhole
Set Rng = .Find(What:=MyArr(I), _
After:=.Cells(.Cells.Count), _
LookIn:=xlFormulas, _
LookAt:=xlPart, _
SearchOrder:=xlByRows, _
SearchDirection:=xlNext, _
MatchCase:=False)
If Not Rng Is Nothing Then
FirstAddress = Rng.Address
Do
Rcount = Rcount + 1
'仅复制值
Sheets("Sheet6").Range("A" & Rcount).Value = Rng.Value
Set Rng = .FindNext(Rng)
Loop While Not Rng Is Nothing And Rng.Address <> FirstAddress
End If
Next I
End With
End Sub
示例说明：运行程序后，将在工作表Sheet5的单元格区域A1:E10中查找带有“@”的单元格，即e-mail地址，然后将这些单元格值依次复制到工作表Sheet6的A列中。注意，本例中使用参数值为xlPart，并且仅复制单元格值，即不带格式。
[示例7]在当前工作表的单元格区域A1:A50中输入数据5和其它的一些数据，然后在VBE编辑器中输入下面的代码。运行后，程序将在单元格A1:A50区域中查找数值5所在的单元格，并在所找到的单元格中画一个蓝色的椭圆。
Sub FindSample1()
Dim Cell As Range, FirstAddress As String
With Worksheets(1).Range("A1:A50")
Set Cell = .Find(5)
If Not Cell Is Nothing Then
FirstAddress = Cell.Address
Do
With Worksheets(1).Ovals.Add(Cell.Left, _
Cell.Top, Cell.Width, _
Cell.Height)
.Interior.Pattern = xlNone
.Border.ColorIndex = 5
End With
Set Cell = .FindNext(Cell)
Loop Until Cell Is Nothing Or Cell.Address = FirstAddress
End If
End With
End Sub
[示例8]在一个列表中复制相关数据到另一个列表
本程序的功能是，根据单元格I1中的值，在单元格区域A1:D11中的B列进行查找，每次找到相应的值，就将该单元格所在区域的行数据复制到以单元格G3(该单元格命名为found)开始的区域中。原数据如下图2所示。
图2：原始数据
点击工作表中的“查找”按钮，运行后的结果如下图3所示。
图3：运行后的结果
源程序代码清单及相关说明如下：
Option Explicit
Sub FindSample2()
Dim ws As Worksheet
Dim rgSearchIn As Range
Dim rgFound As Range
Dim sFirstFound As String
Dim bContinue As Boolean
ReSetFoundList '初始化要复制的列表区域
Set ws = ThisWorkbook.Worksheets("sheet1")
bContinue = True
Set rgSearchIn = GetSearchRange(ws) '获取查找区域
'设置查找参数
Set rgFound = rgSearchIn.Find(what:=ws.Range("I1").Value, _
LookIn:=xlValues, LookAt:=xlWhole)
'获取第一个满足条件的单元格地址,作为结束循环的条件
If Not rgFound Is Nothing Then sFirstFound = rgFound.Address
Do Until rgFound Is Nothing Or Not bContinue
CopyItem rgFound
Set rgFound = rgSearchIn.FindNext(rgFound)
'判断循环是否中止
If rgFound.Address = sFirstFound Then bContinue = False
Loop
Set rgSearchIn = Nothing
Set rgFound = Nothing
Set ws = Nothing
End Sub
'获取查找区域,即B列中的"部位"单元格区域
Private Function GetSearchRange(ws As Worksheet) As Range
Dim lLastRow As Long
lLastRow = ws.Cells(65536, 1).End(xlUp).Row
Set GetSearchRange = ws.Range(ws.Cells(1, 2), ws.Cells(lLastRow, 2))
End Function
'复制查找到的数据到found区域
Private Sub CopyItem(rgItem As Range)
Dim rgDestination As Range
Dim rgEntireItem As Range'获取在查找区域中的整行数据
Set rgEntireItem = rgItem.Offset(0, -1)
Set rgEntireItem = rgEntireItem.Resize(1, 4)
Set rgDestination = rgItem.Parent.Range("found")'定位要复制到的found区域的第一行
If IsEmpty(rgDestination.Offset(1, 0)) Then
Set rgDestination = rgDestination.Offset(1, 0)
Else
Set rgDestination = rgDestination.End(xlDown).Offset(1, 0)
End If
'复制找到的数据到found区域
rgEntireItem.Copy rgDestination
Set rgDestination = Nothing
Set rgEntireItem = Nothing
End Sub
'初始化要复制到的区域(found区域)
Private Sub ReSetFoundList()
Dim ws As Worksheet
Dim lLastRow As Long
Dim rgTopLeft As Range
Dim rgBottomRight As Range
Set ws = ThisWorkbook.Worksheets("sheet1")
Set rgTopLeft = ws.Range("found").Offset(1, 0)
lLastRow = ws.Range("found").End(xlDown).Row
Set rgBottomRight = ws.Cells(lLastRow, rgTopLeft.Offset(0, 3).Column)
ws.Range(rgTopLeft, rgBottomRight).ClearContents
Set rgTopLeft = Nothing
Set rgBottomRight = Nothing
Set ws = Nothing
End Sub
在 上述程序代码中，程序FindSample2( )为主程序，首先调用子程序ReSetFoundList( )对所要复制到的数据区域初始化，即清空除标题行以外的内容；然后调用自定义函数GetSearchRange(ws As Worksheet)获取所在查找的单元格区域；在主程序中使用Find方法和FIndNext方法进行查找，调用带参数的子程序 CopyItem(rgItem As Range)将查找到的单元格所在的数据行复制到相应的区域。
[示例9]实现带连续单元格区域条件的查找
下面的代码提供了一种实现以连续单元格区域中的数据为查找条件进行查找的方法和思路。在本例中，所查找条件区域为D2:D4，在单元格区域A1:A21中进行查找，将结果输入到以单元格F2开始的区域中。示例程序所对应的工作表数据及结果如下图4所示。
Sub FindGroup()
Dim ToFind As Range, Found As Range, c As Range
Dim FirstAddress As String
Set ToFind = Range("D2:D4")
With Worksheets(1).Range("a1:a21")
Set c = .Find(ToFind(1), LookIn:=xlValues)
If Not c Is Nothing Then
FirstAddress = c.Address
Do
If c.Offset(1) = ToFind(2) And c.Offset(2) = ToFind(3) Then
Set Found = Range(c.Offset(0, 1), c.Offset(0, 1).Offset(2))
GoTo Exits
End If
Set c = .FindNext(c)
Loop While Not c Is Nothing And c.Address <> FirstAddress
End If
End With
Exits:
Found.Copy Range("F2")
End Sub
图4：数据及查找结果
[示 例10]本示例所列程序将在工作簿的所有工作表中查找数值，提供了采用两种方法编写的程序，一种是Find方法，另一种是SpecialCells 方法。相对来说，使用Find方法比使用SpecialCells方法要快，当然，本示例可能不明显，但对于带大量工作表和数据的工作簿来说，这种速度差 异就可以看出来了。
示例代码如下，代码中有简要的说明。
'- - -使用Find方法 - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - Sub QuickSearch()
Dim wks As Excel.Worksheet
Dim rCell As Excel.Range
Dim szFirst As String
Dim i As Long '设置变量决定是否加亮显示查找到的单元格
'该变量为真时则加亮显示
Dim bTag As Boolean
bTag = True '使用input接受查找条件的输入
Dim szLookupVal As String
szLookupVal = InputBox("在下面的文本框中输入您想要查找的值", "查找输入框", "")
'如果没有输入任何数据,则退出程序
If szLookupVal = "" Then Exit Sub
Application.ScreenUpdating = False
Application.DisplayAlerts = False
' =============================================================
' 添加一个工作表,在该工作表中放置已查找到的单元格地址
' 如果该工作表存在,则先删除它
For Each wks In ActiveWorkbook.Worksheets
If wks.Name = "查找结果" Then
wks.Delete
End If
Next wks
' 添加工作表
Sheets.Add ActiveSheet
' 重命名所添加的工作表
ActiveSheet.Name = "查找结果"
' 在新增工作表中添加标题,指明所查找的值
With Cells(1, 1)
.Value = "已在下面所列出的位置找到数值" & szLookupVal
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
' =============================================================
' 定位到刚开始的工作表
ActiveSheet.Next.Select
' =============================================================
' 提示您是否想高亮显示已查找到的单元格
If MsgBox("您想加阴影高亮显示所有查找到的单元格吗?", vbYesNo, _
"加阴影高亮显示单元格") = vbNo Then
' 如果不想加阴影显示单元格,则将变量bTag值设置为False
bTag = False
End If
' =============================================================
i = 2
' 开始在工作簿的所有工作表中搜索
For Each wks In ActiveWorkbook.Worksheets
' 检查所有的单元格,Find方法比SpecialCells方法更快
With wks.Cells
Set rCell = .Find(szLookupVal, , , xlWhole, xlByColumns, xlNext, False)
If Not rCell Is Nothing Then
szFirst = rCell.Address
Do
' 添加找到的单元格地址到新工作表中
rCell.Hyperlinks.Add Sheets("查找结果").Cells(i, 1), "", "'" & wks.Name & "'!" & rCell.Address
' 检查条件判断值bTag,以决定是否加亮显示单元格
Select Case bTag
Case True
rCell.Interior.ColorIndex = 19
End Select
Set rCell = .FindNext(rCell)
i = i + 1
Loop While Not rCell Is Nothing And rCell.Address <> szFirst
End If
End With
Next wks
' 释放内存变量
Set rCell = Nothing ' 如果没有找到匹配的值,则移除新增工作表
If i = 2 Then
MsgBox "您所要查找的数值{" & szLookupVal & "}在这些工作表中没有发现", 64, "没有匹配值"
Sheets("查找结果").Delete
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
End Sub
'- - - 使用SpecialCells 方法- - - - - - -
Option Compare Text
Sub SlowerSearch()
Dim wks As Excel.Worksheet
Dim rCell As Excel.Range
Dim i As Long
'设置变量决定是否加亮显示查找到的单元格
'该变量为真时则加亮显示
Dim bTag As Boolean
bTag = True '使用input接受查找条件的输入
Dim szLookupVal As String
szLookupVal = InputBox("在下面的文本框中输入您想要查找的值", "查找输入框", "")
'如果没有输入任何数据,则退出程序
If szLookupVal = "" Then Exit Sub
With Application
.ScreenUpdating = False
.DisplayAlerts = False
.Calculation = xlCalculationManual
' =============================================================
' 添加一个工作表,在该工作表中放置已查找到的单元格地址
' 如果该工作表存在,则先删除它
For Each wks In ActiveWorkbook.Worksheets
If wks.Name = "查找结果" Then
wks.Delete
End If
Next wks
' 添加工作表
Sheets.Add ActiveSheet
' 重命名所添加的工作表
ActiveSheet.Name = "查找结果"
' 在新增工作表中添加标题,指明所查找的值
With Cells(1, 1)
.Value = "已在下面所列出的位置找到数值" & szLookupVal
.EntireColumn.AutoFit
.HorizontalAlignment = xlCenter
End With
' =============================================================
' 定位到刚开始的工作表
ActiveSheet.Next.Select
' =============================================================
' 提示您是否想高亮显示已查找到的单元格
If MsgBox("您想加阴影高亮显示所有查找到的单元格吗?", vbYesNo, _
"加阴影高亮显示单元格") = vbNo Then
' 如果不想加阴影显示单元格,则将变量bTag值设置为False
bTag = False
End If
' =============================================================
i = 2
' 开始在工作簿的所有工作表中搜索
On Error Resume Next
For Each wks In ActiveWorkbook.Worksheets
If wks.Cells.SpecialCells(xlCellTypeConstants).Count = 0 Then GoTo NoSpecCells
For Each rCell In wks.Cells.SpecialCells(xlCellTypeConstants) DoEvents
If rCell.Value = szLookupVal Then
' 添加找到的单元格地址到新工作表中
rCell.Hyperlinks.Add Sheets("查找结果").Cells(i, 1), "", "'" & wks.Name & "'!" & rCell.Address
' 检查条件判断值bTag,以决定是否加亮显示单元格
Select Case bTag
Case True
rCell.Interior.ColorIndex = 19
End Select
i = i + 1
.StatusBar = "查找到的单元格数为: " & i - 2
End If
Next rCell
NoSpecCells:
Next wks
' 如果没有找到匹配的值,则移除新增工作表
If i = 2 Then
MsgBox "您所要查找的数值{" & szLookupVal & "}在这些工作表中没有发现", 64, "没有匹配值"
Sheets("查找结果").Delete
End If
.Calculation = xlCalculationAutomatic
.DisplayAlerts = True
.ScreenUpdating = True
.StatusBar = Empty
End With
End Sub
------------------------------
有后续......
扫一扫
524
被折叠的 条评论
为什么被折叠?
到【灌水乐园】发言
