|
发表于 2017-9-18 09:35
|
显示全部楼层
本楼为最佳答案
Sub grf()
arr = Sheets("采购价").Range("a3:f" & Sheets("采购价").[a65536].End(3).Row)
Set d = CreateObject("scripting.dictionary")
For i = 1 To UBound(arr) '采购价表中,按名称放入字典d,以各行为item
d(arr(i, 2) & arr(i, 3)) = d(arr(i, 2) & arr(i, 3)) & "," & i
Next
r = [a65536].End(3).Row
brr = Range("a3:f" & r)
Set d1 = CreateObject("scripting.dictionary")
ReDim crr(1 To UBound(arr), 1 To UBound(arr, 2))
For i = 1 To UBound(brr)
x = brr(i, 2) & brr(i, 3) '名称+单位
If Not d.exists(x) Then '如果名称在字典中不存在,本行置空
For j = 1 To UBound(brr, 2): brr(i, j) = "": Next
Else
xrr = Split(d(x), ",") '取各行中的第1行内容作为本行内容
ii = xrr(1): d1(Val(ii)) = "" '字典d1控制已经取用过的行
For j = 1 To UBound(brr, 2): brr(i, j) = arr(ii, j): Next
If UBound(xrr) = 1 Then '如果此名称在采购表中只有1行,直接取用,并在字典中去掉(同时解决基准表和采购价多对一的问题)
d.Remove (x)
Else
xrr(1) = "": d(x) = "," & Join(xrr, ",") '如果此名称在采购表中超过1行,取用第1行后,去掉第1行(解决基准表和采购价一对多的问题)
End If
End If
Next
Range("g3").Resize(UBound(brr), UBound(brr, 2)) = brr
For i = 1 To UBound(arr) '查看字典d1,没有取用过的行放到最下面
If Not d1.exists(i) Then
n = n + 1
For j = 1 To UBound(arr, 2)
crr(n, j) = arr(i, j)
Next
End If
Next
Cells(r + 1, "G").Resize(n, UBound(crr, 2)) = crr
End Sub |
|