本帖最后由 dsmch 于 2014-9-30 14:06 编辑
- Sub Macro1()
- Dim arr, brr, d, i&
- Set d = CreateObject("scripting.dictionary")
- arr = Range("a1").CurrentRegion
- ReDim brr(1 To UBound(arr) - 1, 1 To 1)
- For i = 2 To UBound(arr)
- If Not d.exists(arr(i, 4)) Then d(arr(i, 4)) = i Else d(arr(i, 4)) = d(arr(i, 4)) & "," & i
- Next
- For i = 2 To UBound(arr)
- If d.exists(-arr(i, 4)) And arr(i, 4) <> 0 Then
- x = Split(d(-arr(i, 4)), ",")
- For j = 0 To UBound(x)
- If ((arr(i, 2) = arr(x(j), 2) And arr(i, 2) <> "") Or (arr(i, 3) = arr(x(j), 3)) And arr(i, 3) <> "") And arr(x(j), 4) <> 0 Then
- arr(x(j), 4) = 0
- arr(i, 4) = 0
- brr(i - 1, 1) = arr(x(j), 1)
- brr(x(j) - 1, 1) = arr(i, 1)
- GoTo line1
- End If
- Next
- End If
- line1:
- Next
- Range("g2").Resize(UBound(brr)) = brr
- End Sub
复制代码 |