|
[广告] Excel易用宝 - 提升Excel的操作效率 · Excel / WPS表格插件 ★ 免费下载 ★ ★ 使用帮助★
Option Explicit
Sub test()
Dim ar, br, d As Object, Cel As Range, i%, j%, k%, s$, t$
Set d = CreateObject("Scripting.Dictionary")
ar = Sheets("数据").[e65536].End(xlUp).Offset(-99).Resize(100)
With Sheets("查找")
Set Cel = .[cs3]
br = Cel.Resize(3, 5)
For j = 1 To UBound(br, 2) Step 2
Cel.Offset(3, j - 1).Resize(100) = ""
d.RemoveAll
Dim cr()
k = 0
s = br(2, j) & br(3, j)
For i = UBound(ar) To 1 Step -1
If Left(ar(i, 1), 2) = s Then
t = Right(ar(i, 1), 1)
If Not d.exists(t) Then
d(t) = ""
k = k + 1
ReDim Preserve cr(1 To k)
cr(k) = t
End If
End If
Next
If k Then Cel.Offset(3, j - 1).Resize(k) = WorksheetFunction.Transpose(cr)
Next
End With
Set d = Nothing
Set Cel = Nothing
End Sub |
评分
-
3
查看全部评分
-
|