完美Excel

Option Compare Text
Function FindAll(SearchRange As Range, FindWhat As Variant, _
    Optional LookIn As XlFindLookIn = xlValues, Optional LookAt As XlLookAt = xlWhole, _
    Optional SearchOrder As XlSearchOrder = xlByRows, _
    Optional MatchCase As Boolean = False) As Range
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 返回SearchRange区域中含有FindWhat所代表的值的所有单元格组成的Range对象
' 其参数与Find方法的参数相同
' 如果没有找到单元格,将返回Nothing.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  Dim FoundCell As Range
  Dim FoundCells As Range
  Dim LastCell As Range
  Dim FirstAddr As String
  With SearchRange
    Set LastCell = .Cells(.Cells.Count)
  End With
  Set FoundCell = SearchRange.Find(what:=FindWhat, after:=LastCell, _
    LookIn:=LookIn, LookAt:=LookAt, SearchOrder:=SearchOrder, MatchCase:=MatchCase)
  If Not FoundCell Is Nothing Then
    Set FoundCells = FoundCell
    FirstAddr = FoundCell.Address
    Do
      Set FoundCells = Application.Union(FoundCells, FoundCell)
      Set FoundCell = SearchRange.FindNext(after:=FoundCell)
    Loop Until (FoundCell Is Nothing) Or (FoundCell.Address = FirstAddr)
  End If
 
  If FoundCells Is Nothing Then
    Set FindAll = Nothing
  Else
    Set FindAll = FoundCells
  End If
End Function

Sub TestFindAll()
    Dim SearchRange As Range
    Dim FoundCells As Range
    Dim FoundCell As Range
    Dim FindWhat As Variant
    Dim MatchCase As Boolean
    Dim LookIn As XlFindLookIn
    Dim LookAt As XlLookAt
    Dim SearchOrder As XlSearchOrder
 
    Set SearchRange = ThisWorkbook.Worksheets(1).Range("A1:L20")
    FindWhat = "A" '要查找的文本,可根据实际情况自定
    LookIn = xlValues
    LookAt = xlPart
    SearchOrder = xlByRows
    MatchCase = False
 
    Set FoundCells = FindAll(SearchRange:=SearchRange, FindWhat:=FindWhat, _
        LookIn:=LookIn, LookAt:=LookAt, SearchOrder:=SearchOrder, MatchCase:=MatchCase)
 
    If FoundCells Is Nothing Then
        Debug.Print "没有找到!"
    Else
        For Each FoundCell In FoundCells.Cells
            Debug.Print FoundCell.Address, FoundCell.Text
        Next FoundCell
    End If
 
End Sub

Function WildCardMatchCells(SearchRange As Range, CompareLikeString As String, _
    Optional SearchOrder As XlSearchOrder = xlByRows, _
    Optional MatchCase As Boolean = False) As Range
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' 本程序返回文本值与通配符字符串相匹配的单元格引用
' 返回SearchRange区域中所有相匹配的单元格
' 匹配的条件是参数CompareLikeString
' 使用了VBA中的LIKE运算符
' 如果没有相匹配的单元格或指定了一个无效的参数,则返回Nothing.
'
' 参数SearchOrder指定查找的方向;逐行还是逐列(SearchOrder:=xlByRows或SearchOrder:=xlByColumns
' 参数MatchCase指定是否区分大小写(MatchCase:=True, "A" <> "a")或(MatchCase:=False,"A" = "a").
'
' 不需要在模块顶指定"Option Compare Text",如果指定的话,将不会正确执行大小写比较
'
' 执行单元格中的Text属性比较,而不是Value属性比较
' 因此,仅比较显示在屏幕中的文本,而不是隐藏在单元格中具体的值
'
' 如果参数SearchRange是nothing或多个区域,则返回Nothing.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
  Dim FoundCells As Range
  Dim FirstCell As Range
  Dim LastCell As Range
  Dim RowNdx As Long
  Dim ColNdx As Long
  Dim StartRow As Long
  Dim EndRow As Long
  Dim StartCol As Long
  Dim EndCol As Long
  Dim WS As Worksheet
  Dim Rng As Range
 
' 确保参数SearchRange不是Nothing且是一个单独的区域
  If SearchRange Is Nothing Then
    Exit Function
  End If
  If SearchRange.Areas.Count > 1 Then
    Exit Function
  End If
 
  With SearchRange
    Set WS = .Worksheet
    Set FirstCell = .Cells(1)
    Set LastCell = .Cells(.Cells.Count)
  End With
 
  StartRow = FirstCell.Row
  StartCol = FirstCell.Column
  EndRow = LastCell.Row
  EndCol = LastCell.Column
 
  If SearchOrder = xlByRows Then
    With WS
      For RowNdx = StartRow To EndRow
        For ColNdx = StartCol To EndCol
          Set Rng = .Cells(RowNdx, ColNdx)
            If MatchCase = False Then
             '''''''''''''''''''''''''''''''''''
             '如果参数MatchCase是False,则将字符串转换成大写
             '执行忽略大小写的比较
             '因此,MatchCase:=False比MatchCase:=True更慢
             '''''''''''''''''''''''''''''''''''
               If UCase(Rng.Text) Like UCase(CompareLikeString) Then
                 If FoundCells Is Nothing Then
                    Set FoundCells = Rng
                 Else
                    Set FoundCells = Application.Union(FoundCells, Rng)
                 End If
               End If
              Else
                ''''''''''''''''''''''''''''''''''''''''''''''''
                ' MatchCase为真,不需要再进行大小写转换,因此更快些
                ' 这也是不需要在模块中指定"Option Compare Text"的原因
                ''''''''''''''''''''''''''''''''''''''''''''''''
                If Rng.Text Like CompareLikeString Then
                  If FoundCells Is Nothing Then
                    Set FoundCells = Rng
                  Else
                    Set FoundCells = Application.Union(FoundCells, Rng)
                  End If
                End If
            End If
        Next ColNdx
      Next RowNdx
    End With
  Else
    With WS
      For ColNdx = StartCol To EndCol
        For RowNdx = StartRow To EndRow
          Set Rng = .Cells(RowNdx, ColNdx)
          If MatchCase = False Then
            If UCase(Rng.Text) Like UCase(CompareLikeString) Then
              If FoundCells Is Nothing Then
                Set FoundCells = Rng
              Else
                Set FoundCells = Application.Union(FoundCells, Rng)
              End If
            End If
          Else
            If Rng.Text Like CompareLikeString Then
              If FoundCells Is Nothing Then
                Set FoundCells = Rng
              Else
                Set FoundCells = Application.Union(FoundCells, Rng)
              End If
            End If
          End If
        Next RowNdx
      Next ColNdx
    End With
  End If
 
  If FoundCells Is Nothing Then
    Set WildCardMatchCells = Nothing
  Else
    Set WildCardMatchCells = FoundCells
  End If
End Function

Sub TestWildCardMatchCells()
    Dim SearchRange As Range
    Dim FoundCells As Range
    Dim FoundCell As Range
    Dim CompareLikeString As String
    Dim SearchOrder As XlSearchOrder
    Dim MatchCase As Boolean
 
    Set SearchRange = Range("A1:IV65000")
    CompareLikeString = "A?C*"
    SearchOrder = xlByRows
    MatchCase = True
 
    Set FoundCells = WildCardMatchCells(SearchRange:=SearchRange, CompareLikeString:=CompareLikeString, _
        SearchOrder:=SearchOrder, MatchCase:=MatchCase)
    If FoundCells Is Nothing Then
        Debug.Print "没有找到!"
    Else
        For Each FoundCell In FoundCells
          Debug.Print FoundCell.Address, FoundCell.Text
        Next FoundCell
    End If
End Sub