|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Sub test()
- Dim arr, d, i, brr(), rng As Range, rrng As Range
- Set d = CreateObject("scripting.dictionary")
- arr = Range("a1").CurrentRegion
- For i = 1 To UBound(arr)
- d(arr(i, 2)) = arr(i, 1)
- Next
- For i = 1 To UBound(arr)
- k = k + 1
- ReDim Preserve brr(1 To k)
- If Not d.exists(Val(Right(Val(Cells(i, 3)), 6))) Then
- brr(k) = ""
- If rng Is Nothing Then
- Set rng = Cells(i, 3)
- Else
- Set rng = Union(rng, Cells(i, 3))
- End If
- Else
- brr(k) = d(Val(Right(Val(Cells(i, 3)), 6)))
- d.Remove (Val(Right(Val(Cells(i, 3)), 6)))
- End If
- Next
- k = d.keys
- For i = LBound(k) To UBound(k)
- For j = LBound(arr) To UBound(arr)
- If k(i) = Cells(j, 2) Then
- If rrng Is Nothing Then
- Set rrng = Cells(j, 2)
- Else
- Set rrng = Union(rrng, Cells(j, 2))
- End If
- End If
- Next
- Next
- rrng.Font.ColorIndex = 3
- rng.Font.ColorIndex = 3
- Range("d1").Resize(UBound(brr)) = Application.WorksheetFunction.Transpose(brr)
- Set d = Nothing
- End Sub
复制代码 |
|