方法value作用于对象range时失败_Range对象之Find方法应用(2)

[建议分享到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所示。

点击工作表中的“查找”按钮，运行后的结果如下图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

[示 例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

------------------------------

有后续......