Excel应用实践16：搜索工作表指定列范围中的数据并将其复制到另一个工作表中

Private Sub cmdOK_Click()
    Dim wks As Worksheet
    Dim lngRow As Long
    Dim rngSearch As Range
    Dim FindWhat As Variant
    Dim rngFoundCells As Range
    Dim rngFoundCell As Range
    Dim lngCurRow As Long
    Application.ScreenUpdating = False
    '赋值为工作表Sheet1
    Set wks = Worksheets("Sheet1")
    With wks
        '工作表中的最后一个数据行
        lngRow = .Range("A" &Rows.Count).End(xlUp).Row
        '被查找的单元格区域
        Set rngSearch = .Range("O2:T"& lngRow)
        '查找的数据文本值
        '由用户在文本框中输入
        FindWhat = "*" &Me.txtSearch.Text & "*"
        '调用FindAll函数查找数据值
        '存储满足条件的所有单元格
        Set rngFoundCells =FindAll(SearchRange:=rngSearch, _
                            FindWhat:=FindWhat,_
                            LookIn:=xlValues, _
                            LookAt:=xlWhole, _
                           SearchOrder:=xlByColumns, _
                            MatchCase:=False, _
                           BeginsWith:=vbNullString, _
                           EndsWith:=vbNullString, _
                           BeginEndCompare:=vbTextCompare)
        '如果没有找到则给出消息
        If rngFoundCells Is Nothing Then
            GoTo SendInfo
        End If
        '清空工作表Sheet2
        Sheets("Sheet2").Cells.Clear
        '获取数据单元格所在的行并复制到工作表Sheet2
        For Each rngFoundCell In rngFoundCells
                lngCurRow =Val(Mid(rngFoundCell.Address, 4, Len(rngFoundCell.Address)))
                Range("A" &lngCurRow & ":Z" & lngCurRow).Copy _
                   Sheets("Sheet2").Cells(Rows.Count, 1).End(xlUp).Offset(1)
        Next rngFoundCell
    End With
    Application.ScreenUpdating = True
    Unload Me
    Exit Sub
SendInfo:
    MsgBox "没有找到数据", , "查找"
End Sub

'自定义函数
'获取满足条件的所有单元格
Function FindAll(SearchRange AsRange, _
                FindWhat As Variant, _
               Optional LookIn As XlFindLookIn= xlValues, _
                Optional LookAt As XlLookAt =xlWhole, _
                Optional SearchOrder AsXlSearchOrder = xlByRows, _
                Optional MatchCase As Boolean =False, _
                Optional BeginsWith As String =vbNullString, _
                Optional EndsWith As String =vbNullString, _
                Optional BeginEndCompare AsVbCompareMethod = vbTextCompare) As Range
    Dim FoundCell As Range
    Dim FirstFound As Range
    DimLastCell As Range
    Dim ResultRange As Range
    Dim XLookAt As XlLookAt
    Dim Include As Boolean
    Dim CompMode As VbCompareMethod
    Dim Area As Range
    Dim MaxRow As Long
    Dim MaxCol As Long
    Dim BeginB As Boolean
    Dim EndB As Boolean
    CompMode = BeginEndCompare
    If BeginsWith <> vbNullString OrEndsWith <> vbNullString Then
        XLookAt = xlPart
    Else
        XLookAt = LookAt
    End If
    For Each Area In SearchRange.Areas
        With Area
            If .Cells(.Cells.Count).Row >MaxRow Then
                MaxRow =.Cells(.Cells.Count).Row
            End If
            If .Cells(.Cells.Count).Column >MaxCol Then
                MaxCol =.Cells(.Cells.Count).Column
            End If
        End With
    Next Area
    Set LastCell =SearchRange.Worksheet.Cells(MaxRow, MaxCol)
    On Error GoTo 0
    Set FoundCell =SearchRange.Find(What:=FindWhat, _
        after:=LastCell, _
        LookIn:=LookIn, _
        LookAt:=XLookAt, _
        SearchOrder:=SearchOrder, _
        MatchCase:=MatchCase)
    If Not FoundCell Is Nothing Then
        Set FirstFound = FoundCell
        Do Until False
            Include = False
            If BeginsWith = vbNullString AndEndsWith = vbNullString Then
                Include = True
            Else
                If BeginsWith <>vbNullString Then
                    IfStrComp(Left(FoundCell.Text, Len(BeginsWith)), BeginsWith, BeginEndCompare) = 0Then
                        Include = True
                    End If
                End If
                If EndsWith <>vbNullString Then
                    If StrComp(Right(FoundCell.Text,Len(EndsWith)), EndsWith, BeginEndCompare) = 0 Then
                        Include = True
                    End If
                End If
            End If
            If Include = True Then
                If ResultRange Is Nothing Then
                    Set ResultRange = FoundCell
                Else
                    Set ResultRange =Application.Union(ResultRange, FoundCell)
                End If
            End If
            Set FoundCell = SearchRange.FindNext(after:=FoundCell)
            If (FoundCell Is Nothing) Then
                Exit Do
            End If
            If (FoundCell.Address =FirstFound.Address) Then
                Exit Do
            End If
        Loop
    End If
    Set FindAll = ResultRange
End Function