|
WildCardMatchCells函数
这个程序查找参数SearchRange所代表的区域中所有单元格，使用Like运算符将它们的值与参数CompareLikeString所代表的值比较。参数SearchRange必须是一个单独的区域，参数CompareLikeString是想要比较的文本的格式。该函数使用单元格的Text属性而不是Value属性。可选参数SearchOrder和MatchCase与Find方法中的参数意义相同。
该函数返回一个Range对象，该对象包含对与参数CompareLikeString相匹配的所有单元格的引用。如果没有匹配的单元格，则返回Nothing。
因为Find方法不支持通配符，程序将循环所有的单元格，因此对于包含大量数据的区域，执行时间可能是一个问题。并且，如果参数MatchCase为False或忽略该参数，文本在程序中必须被转换成大写，以便于查找时不区分大小写(即“A”=“a”)，因此，此时程序运行将更慢。
WildCardMatchCells函数的代码如下：
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
这样，在找到所需单元格后，就可以对这些单元格进行操作了。 | 
[复制链接]
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2007-2-12 13:31
楼主
