关于查找方法(Find方法)的应用(二)

关于查找方法(Find方法)的应用(二)

---

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 数据及查找结果