以下仅在你的原代码上稍加了点,是否是你想要的?
Sub 实验查找1()
Call 查找("xxx", "e")
End Sub
Sub 实验查找2()
Call 查找(Array("xxx", "dxx"), "e")
End Sub
Sub 查找(zhao, Ly$)
Dim RB&, k&, i&, ar1, Ads1$, Ads2$, r&, key, col%
Dim MRG As Range, C As Range, arr(), brr(), J&, jj&, tmp()
RB = Range("B65536").End(xlUp).Row
ReDim arr(1)
If Not IsArray(zhao) Then
ReDim tmp(1 To 1)
tmp(1) = zhao
Else
tmp = zhao
End If
col = 8
For Each key In tmp
Set C = Range(Ly & "2:" & Ly & RB).Find(What:=key, LookIn:=xlValues, LookAt:=xlPart)
If Not C Is Nothing Then
arr(1) = C.Offset(0, -2)
Ads1 = C.Address: r = C.Row: k = 1 ' k = 0
Do
Set C = Range(Ly & "2:" & Ly & RB).FindNext(C) '下一个的循环
Ads2 = C.Address
If Ads2 <> Ads1 Then
k = k + 1
ReDim Preserve arr(k)
arr(k) = C.Offset(0, -2)
End If
Loop While Ads1 <> C.Address And Not C Is Nothing
Columns(col).ClearContents
Cells(1, col).Resize(UBound(arr), 1) = Application.WorksheetFunction.Transpose(arr)
col = col + 1
End If
Next
End Sub
以下仅在你的原代码上稍加了点,是否是你想要的?
Sub 实验查找1()
Call 查找("xxx", "e")
End Sub
Sub 实验查找2()
Call 查找(Array("xxx", "dxx"), "e")
End Sub
Sub 查找(zhao, Ly$)
Dim RB&, k&, i&, ar1, Ads1$, Ads2$, r&, key, col%
Dim MRG As Range, C As Range, arr(), brr(), J&, jj&, tmp()
RB = Range("B65536").End(xlUp).Row
ReDim arr(1)
If Not IsArray(zhao) Then
ReDim tmp(1 To 1)
tmp(1) = zhao
Else
tmp = zhao
End If
col = 8
For Each key In tmp
Set C = Range(Ly & "2:" & Ly & RB).Find(What:=key, LookIn:=xlValues, LookAt:=xlPart)
If Not C Is Nothing Then
arr(1) = C.Offset(0, -2)
Ads1 = C.Address: r = C.Row: k = 1 ' k = 0
Do
Set C = Range(Ly & "2:" & Ly & RB).FindNext(C) '下一个的循环
Ads2 = C.Address
If Ads2 <> Ads1 Then
k = k + 1
ReDim Preserve arr(k)
arr(k) = C.Offset(0, -2)
End If
Loop While Ads1 <> C.Address And Not C Is Nothing
Columns(col).ClearContents
Cells(1, col).Resize(UBound(arr), 1) = Application.WorksheetFunction.Transpose(arr)
col = col + 1
End If
Next
End Sub