[VBA]关于查找方法(Find方法)的应用(二)
fanjy 发表于 2006-9-28 20:26:00
5. 综合示例
5.1 示例一：在当前工作表的单元格区域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
‘- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
[参考] 参见《使VBA代码更快且更简洁的方法》一文中的“使用已有的VBA方法：Find方法”，体验使用传统的循环方法与使用该方法实现相同功能时，VBA代码速度的差异。
5.2 示例二：在一个列表中复制相关数据到另一个列表(Revised from Hansen’s Programming)
本程序的功能是，根据单元格I1中的值，在单元格区域A1:D11中的B列进行查找，每次找到相应的值，就将该单元格所在区域的行数据复制到以单元格G3(该单元格命名为found)开始的区域中。原数据如下图03所示。
图03：原始数据
点击工作表中的“查找”按钮，运行后的结果如下图04所示。
图04：运行后的结果
源程序代码清单及相关说明如下：
‘- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
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)将查找到的单元格所在的数据行复制到相应的区域。
示例文档见 Find方法示例1.xls。UploadFiles/2006-9/928354714.rar
5.3 示例三：实现带连续单元格区域条件的查找
下面的代码提供了一种实现以连续单元格区域中的数据为查找条件进行查找的方法和思路。在本例中，所查找条件区域为D2:D4，在单元格区域A1:A21中进行查找，将结果输入到以单元格F2开始的区域中。示例程序所对应的工作表数据及结果如下图06所示。
‘- - - - - - - - - -代码清单- - - - - - - - - - - - - - - - - - - - - -
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
‘- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
图05 数据及查找结果
By fanjy in 2006-9-28