BOM查找子件重复项

wspop

求助各位大神，编写VBA程序BOM查找子件重复项
要求找出每个母件下面的子件是否有相同的信息，如果有相同的信息就标记颜色
另如有可能进行从新排序，将相同的放在一起

十分感谢大家！！！

蓝桥玄霜

请见代码。

wspop

大神图片看不清楚啊，可以发代码，谢谢！！！
Sub lqxs()
Dim Arr, i&, x$, y$, kk, tt, aa, j&, ii&
Dim d, k, t
Set d = CreateObject("Scripting.Dictionary")
Sheet1.Activate
Cells .Interi or .ColorIndex = xlNone
Arr = [al].CurrentRegion
For i = 2 To UBound(Arr)
    x = Arr(i, 1): y = Arr(i, 4)
    If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
    d(x)(y) = d(x)(y) & i & ","
Next
k = d.keys: t = d.items
For i = 0 To UBound(k)
    kk = t(i).keys: tt = t(i).items
    For ii = 0 To UBound(kk)
        tt(ii) = Left(tt(ii), Len(tt(ii)) - 1)
        If InStr(tt(ii), ",") Then
            aa = Split(tt(ii), ",")
            For j = 0 To UBound(aa)
                Cells(aa(j), 4).Resize(1, 5).Interior.ColorIndex = 6
            Next
        End If
    Next
Next
[al].CurrentRegion.Sort Keyl:=Range("A2"), Orderl:=xlAscending, Key2:=Range("D2"), Orderl:=xlAscending, Header:=xlYes
End Sub

小花鹿

wspop 发表于 2018-10-10 19:14
大神图片看不清楚啊，可以发代码，谢谢！！！

很清楚啊                                                                                                                          

wspop

各位大神，请看附件图片，有错误。可能是我没有看清楚代码
！请帮忙修改一下
Sub lqxs()
Dim Arr, i&, x$, y$, kk, tt, aa, j&, ii&
Dim d, k, t
Set d = CreateObject("Scripting.Dictionary")
Sheet1.Activate
Cells .Interior .ColorIndex = xlNone
Arr = [al].CurrentRegion
For i = 2 To UBound(Arr)
    x = Arr(i, 1): y = Arr(i, 4)
    If d.exists(x) = False Then Set d(x) = CreateObject("Scripting.Dictionary")
    d(x)(y) = d(x)(y) & i & ","
Next

k = d.keys: t = d.items
For i = 0 To UBound(k)
    kk = t(i).keys: tt = t(i).items
    For ii = 0 To UBound(kk)
        tt(ii) = Left(tt(ii), Len(tt(ii)) - 1)
        If InStr(tt(ii), ",") Then
            aa = Split(tt(ii), ",")
            For j = 0 To UBound(aa)
                Cells(aa(j), 4).Resize(1, 5).Interior.ColorIndex = 6
            Next
        End If
    Next
Next
[al].CurrentRegion.Sort Keyl:=Range("A2"), Orderl:=xlAscending, Key2:=Range("D2"), Orderl:=xlAscending, Header:=xlYes
End Sub

aman1516

wspop 发表于 2018-10-11 09:12
各位大神，请看附件图片，有错误。可能是我没有看清楚代码
！请帮忙修改一下
Sub lqxs()

点前面及InteriOr中间都多了个空格，应是：
Cells.Interior.ColorIndex = xlNone

yjh_27

Sheetl.Activate

1. Sheet1.Activate

复制代码

zpy2

Cells .Interi Or .ColorIndex = xlNone
这句估计也有问题。