|
[广告] VBA代码宝 - VBA编程加强工具 · VBA代码随查随用 · 内置多项VBA编程加强工具 ★ 免费下载 ★ ★ 使用手册★
- Sub test()
- Dim r%, i%
- Dim arr, brr
- Dim d As Object
- Set d = CreateObject("scripting.dictionary")
- With Worksheets("表二")
- r = .Cells(.Rows.Count, 2).End(xlUp).Row
- arr = .Range("b5:e" & r)
- For i = 1 To UBound(arr)
- xm = arr(i, 1) & "+" & arr(i, 2) & "+" & arr(i, 3)
- If Not d.Exists(xm) Then
- m = 1
- ReDim brr(1 To 2)
- brr(1) = arr(i, 4)
- brr(2) = i + 4
- Else
- brr = d(xm)
- brr(1) = brr(1) + arr(i, 4)
- brr(2) = brr(2) & "、" & i + 4
- End If
- d(xm) = brr
- Next
- End With
- With Worksheets("表一")
- r = .Cells(.Rows.Count, 1).End(xlUp).Row
- arr = .Range("a6:f" & r)
- ReDim crr(1 To UBound(arr), 1 To 2)
- For i = 1 To UBound(arr)
- xm = arr(i, 3) & "+" & arr(i, 4) & "+" & arr(i, 5)
- If d.Exists(xm) Then
- brr = d(xm)
- crr(i, 1) = brr(1)
- If InStr(brr(2), "、") <> 0 Then
- crr(i, 2) = brr(2) & "行重复,请检查"
- End If
- Else
- crr(i, 1) = "无数据"
- End If
- Next
- .Range("i6").Resize(UBound(crr), 2) = crr
- End With
- End Sub
复制代码 |
|