Excel 如何在多级BOM表中突出显示重复的参考指示器_Excel_Vba

Excel 如何在多级BOM表中突出显示重复的参考指示器

excel vba

Excel 如何在多级BOM表中突出显示重复的参考指示器,excel,vba,Excel,Vba,我正在处理一个宏，该宏在多级物料清单的直接顶层下突出显示重复的参考指示器我的代码如下： 'To identify duplicates RDs Sheet1.Columns(14).Copy (Sheet4.Cells(1, 1)) Sheet4.Select Sheet4.Rows("1:1").Select Selection.Copy Selection.Insert shift:=xlDown Cells.Select Selection.A

我正在处理一个宏，该宏在多级物料清单的直接顶层下突出显示重复的参考指示器

我的代码如下：

'To identify duplicates RDs
Sheet1.Columns(14).Copy (Sheet4.Cells(1, 1))

Sheet4.Select
    Sheet4.Rows("1:1").Select
    Selection.Copy
    Selection.Insert shift:=xlDown
    Cells.Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$A$10000").AutoFilter Field:=1, Criteria1:="="
    Cells.Select
    Selection.Delete shift:=xlUp
    Sheet4.Columns(1).Interior.ColorIndex = xlNone


    Dim FromLine As Integer
    Dim ToLine As Integer
    Dim Count As Integer
    Dim Leng As Integer
    Dim RefTemp, RefTemp1, RefTemp2 As String
    Dim Cha As String
    Dim ReferenceNo As String
    Dim PartNo As String
    Dim Description As String
    Dim Flag As Boolean

    FromLine = 1
    Cha = " "
    While Cells(FromLine, 1) <> ""
        Flag = True
        ReferenceNo = LTrim(Cells(FromLine, 1))
        RefTemp = RTrim(ReferenceNo)
        Leng = Len(RefTemp)
        Cells(FromLine, 1) = RefTemp
        Count = 1
        While Count <= Leng And Flag

            RefTemp1 = Left(ReferenceNo, 1)
            If RefTemp1 <> " " And RefTemp1 <> "," Then

                ReferenceNo = Right(ReferenceNo, Leng - Count)

            Else
                Cells(FromLine, 1) = Left(RefTemp, Count - 1)
                Flag = False
                RefTemp2 = Right(ReferenceNo, Leng - Count)

                FromLine = FromLine + 1
                Rows(FromLine).Select
                Selection.Insert shift:=xlDown
                Cells(FromLine, 1) = RefTemp2

                FromLine = FromLine - 1
            End If
            Count = Count + 1
        Wend
        FromLine = FromLine + 1

    Wend


    Dim cel1 As Variant
    Dim myrng1 As Range
    Dim clr1 As Long
    Set myrng1 = Sheet4.Range("A1:A" & Sheet4.Range("A65536").End(xlUp).Row)
    myrng1.Interior.ColorIndex = xlNone

    j = 1

    For Each cel1 In myrng1
        If Application.WorksheetFunction.CountIf(myrng1, cel1) > 1 Then
            If WorksheetFunction.CountIf(Sheet4.Range("A1:A" & cel1.Row), cel1) = 1 Then

                Sheet4.Cells(j, 2).Value = cel1
                j = j + 1

            Else
                cel1.Interior.ColorIndex = myrng1.Cells(WorksheetFunction.Match(cel1.Value, myrng1, False), 1).Interior.ColorIndex
            End If
        End If
    Next


Dim lastrow4 As Long
 lastrow4 = Sheet4.Range("B" & Rows.Count).End(xlUp).Row

For i = 1 To lastrow4
    For j = 1 To lastrow
        k1 = InStr(Sheet1.Cells(j, 14).Value, Sheet4.Cells(i, 2).Value)
        len1 = Len(Sheet4.Cells(i, 2).Value)

        If k1 > 0 Then
            Sheet1.Cells(j, 14).Interior.ColorIndex = 28
            Sheet1.Cells(j, 14).Characters(k1, len1).Font.ColorIndex = 3
        End If
    Next j
Next i
Sheet4.Rows("1:" & Rows.Count).Delete shift:=xlUp


Sheet1.Select

'To identify duplicates RDs
Sheet1.Columns(14).Copy (Sheet4.Cells(1, 1))

Sheet4.Select
    Sheet4.Rows("1:1").Select
    Selection.Copy
    Selection.Insert shift:=xlDown
    Cells.Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$A$10000").AutoFilter Field:=1, Criteria1:="="
    Cells.Select
    Selection.Delete shift:=xlUp
    Sheet4.Columns(1).Interior.ColorIndex = xlNone


    Dim FromLine As Integer
    Dim ToLine As Integer
    Dim Count As Integer
    Dim Leng As Integer
    Dim RefTemp, RefTemp1, RefTemp2 As String
    Dim Cha As String
    Dim ReferenceNo As String
    Dim PartNo As String
    Dim Description As String
    Dim Flag As Boolean

    FromLine = 1
    Cha = " "
    While Cells(FromLine, 1) <> ""
        Flag = True
        ReferenceNo = LTrim(Cells(FromLine, 1))
        RefTemp = RTrim(ReferenceNo)
        Leng = Len(RefTemp)
        Cells(FromLine, 1) = RefTemp
        Count = 1
        While Count <= Leng And Flag

            RefTemp1 = Left(ReferenceNo, 1)
            If RefTemp1 <> " " And RefTemp1 <> "," Then

                ReferenceNo = Right(ReferenceNo, Leng - Count)

            Else
                Cells(FromLine, 1) = Left(RefTemp, Count - 1)
                Flag = False
                RefTemp2 = Right(ReferenceNo, Leng - Count)
                'PartNo = Cells(FromLine, 2)
                'Description = Cells(FromLine, 3)
                FromLine = FromLine + 1
                Rows(FromLine).Select
                Selection.Insert shift:=xlDown
                Cells(FromLine, 1) = RefTemp2
                'Cells(FromLine, 2) = PartNo
                'Cells(FromLine, 3) = Description
                FromLine = FromLine - 1
            End If
            Count = Count + 1
        Wend
        FromLine = FromLine + 1

    Wend


    Dim cel1 As Variant
    Dim myrng1 As Range
    Dim clr1 As Long
    Set myrng1 = Sheet4.Range("A1:A" & Sheet4.Range("A65536").End(xlUp).Row)
    myrng1.Interior.ColorIndex = xlNone

    j = 1

    For Each cel1 In myrng1
        If Application.WorksheetFunction.CountIf(myrng1, cel1) > 1 Then
            If WorksheetFunction.CountIf(Sheet4.Range("A1:A" & cel1.Row), cel1) = 1 Then
                'cel1.Interior.ColorIndex = 7
                'cel1.Font.ColorIndex = 1
                Sheet4.Cells(j, 2).Value = cel1
                j = j + 1

            Else
                cel1.Interior.ColorIndex = myrng1.Cells(WorksheetFunction.Match(cel1.Value, myrng1, False), 1).Interior.ColorIndex
            End If
        End If
    Next


Dim lastrow4 As Long
 lastrow4 = Sheet4.Range("B" & Rows.Count).End(xlUp).Row

 Dim myarr() As String

For i = 1 To lastrow4
    For j = 1 To lastrow

        myarr() = Split(Sheet1.Cells(j, 14).Value, ",")

        k1 = 0

        For y = LBound(myarr) To UBound(myarr)
            If myarr(y) = Sheet4.Cells(i, 2).Value Then
                k1 = 1
            End If
        Next y


        'L1 = InStr(Sheet1.Cells(j, 14).Value, Sheet4.Cells(i, 2).Value)
        len1 = Len(Sheet4.Cells(i, 2).Value)



        If Not IsEmpty(Sheet4.Cells(i, 2)) Then
            If k1 > 0 Then
                Start = 1

                Do
                 L1 = InStr(Start, Sheet1.Cells(j, 14).Value, Sheet4.Cells(i, 2).Value)

                If L1 > 0 Then
                    Start = L1 + 1
                    Sheet1.Cells(j, 14).Interior.ColorIndex = 28
                    Sheet1.Cells(j, 14).Characters(L1, len1).Font.ColorIndex = 3
                End If
                Loop While L1 > 0


            End If
        End If
    Next j
Next i
Sheet4.Rows("1:" & Rows.Count).Delete shift:=xlUp


Sheet1.Select

”以识别重复的RDs
表1.列（14）.副本（表4.单元格（1,1））
表4.选择
表4.行（“1:1”）。选择
选择，复制
选择。插入移位：=xlDown
单元格。选择
自动筛选
ActiveSheet.Range（“$A$1:$A$10000”）。自动筛选字段：=1，标准1:=”
单元格。选择
选择。删除移位：=xlUp
表4.列（1）.Interior.ColorIndex=xlNone
将FromLine设置为整数
作为整数的Dim-ToLine
将计数设置为整数
作为整数的Dim Leng
将RefTemp、RefTemp1、RefTemp2标注为字符串
把茶当绳子
作为字符串的Dim ReferenceNo
作为字符串的Dim PartNo
以字符串形式显示的模糊描述
将标志变暗为布尔值
FromLine=1
Cha=“”
While单元格（FromLine，1）”
Flag=True
ReferenceNo=LTrim（单元格（FromLine，1））
参考温度=RTrim（参考温度）
长度=长度（参考温度）
单元格（FromLine，1）=参考温度
计数=1
然后数到1
如果工作表function.CountIf（Sheet4.Range（“A1:A”和cel1.Row），cel1）=1，则
表4.单元格（j，2）.值=cel1
j=j+1
其他的
cel1.Interior.ColorIndex=myrng1.Cells（WorksheetFunction.Match（cel1.Value，myrng1，False），1）。Interior.ColorIndex
如果结束
如果结束
下一个
暗淡最后一行4一样长
lastrow4=Sheet4.Range（“B”和Rows.Count）.End（xlUp）.Row
对于i=1到最后一行4
对于j=1到最后一行
k1=仪表（表1.单元（j，14）.值，表4.单元（i，2）.值）
len1=Len（表4.单元格（i，2）.值）
如果k1>0，则
表1.单元格（j，14）.内部颜色索引=28
Sheet1.单元格（j，14）.字符（k1，len1）.Font.ColorIndex=3
如果结束
下一个j
接下来我
Sheet4.行（“1:”&Rows.Count）。删除移位：=xlUp
表1.选择

问题：

要求在直接顶层下突出显示重复的“参考标示”

例如，在上面的屏幕截图中，“P2”和“P3”是“M1”的直接子女（P2和P3为2级，M1为1级）

因此，在N列中，字母J高亮显示。这是正确的

但P4是M2的产物。它不能突出显示

请帮助。

我已找到上述问题的解决方案，如下所示：

'To identify duplicates RDs
Sheet1.Columns(14).Copy (Sheet4.Cells(1, 1))

Sheet4.Select
    Sheet4.Rows("1:1").Select
    Selection.Copy
    Selection.Insert shift:=xlDown
    Cells.Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$A$10000").AutoFilter Field:=1, Criteria1:="="
    Cells.Select
    Selection.Delete shift:=xlUp
    Sheet4.Columns(1).Interior.ColorIndex = xlNone


    Dim FromLine As Integer
    Dim ToLine As Integer
    Dim Count As Integer
    Dim Leng As Integer
    Dim RefTemp, RefTemp1, RefTemp2 As String
    Dim Cha As String
    Dim ReferenceNo As String
    Dim PartNo As String
    Dim Description As String
    Dim Flag As Boolean

    FromLine = 1
    Cha = " "
    While Cells(FromLine, 1) <> ""
        Flag = True
        ReferenceNo = LTrim(Cells(FromLine, 1))
        RefTemp = RTrim(ReferenceNo)
        Leng = Len(RefTemp)
        Cells(FromLine, 1) = RefTemp
        Count = 1
        While Count <= Leng And Flag

            RefTemp1 = Left(ReferenceNo, 1)
            If RefTemp1 <> " " And RefTemp1 <> "," Then

                ReferenceNo = Right(ReferenceNo, Leng - Count)

            Else
                Cells(FromLine, 1) = Left(RefTemp, Count - 1)
                Flag = False
                RefTemp2 = Right(ReferenceNo, Leng - Count)

                FromLine = FromLine + 1
                Rows(FromLine).Select
                Selection.Insert shift:=xlDown
                Cells(FromLine, 1) = RefTemp2

                FromLine = FromLine - 1
            End If
            Count = Count + 1
        Wend
        FromLine = FromLine + 1

    Wend


    Dim cel1 As Variant
    Dim myrng1 As Range
    Dim clr1 As Long
    Set myrng1 = Sheet4.Range("A1:A" & Sheet4.Range("A65536").End(xlUp).Row)
    myrng1.Interior.ColorIndex = xlNone

    j = 1

    For Each cel1 In myrng1
        If Application.WorksheetFunction.CountIf(myrng1, cel1) > 1 Then
            If WorksheetFunction.CountIf(Sheet4.Range("A1:A" & cel1.Row), cel1) = 1 Then

                Sheet4.Cells(j, 2).Value = cel1
                j = j + 1

            Else
                cel1.Interior.ColorIndex = myrng1.Cells(WorksheetFunction.Match(cel1.Value, myrng1, False), 1).Interior.ColorIndex
            End If
        End If
    Next


Dim lastrow4 As Long
 lastrow4 = Sheet4.Range("B" & Rows.Count).End(xlUp).Row

For i = 1 To lastrow4
    For j = 1 To lastrow
        k1 = InStr(Sheet1.Cells(j, 14).Value, Sheet4.Cells(i, 2).Value)
        len1 = Len(Sheet4.Cells(i, 2).Value)

        If k1 > 0 Then
            Sheet1.Cells(j, 14).Interior.ColorIndex = 28
            Sheet1.Cells(j, 14).Characters(k1, len1).Font.ColorIndex = 3
        End If
    Next j
Next i
Sheet4.Rows("1:" & Rows.Count).Delete shift:=xlUp


Sheet1.Select

'To identify duplicates RDs
Sheet1.Columns(14).Copy (Sheet4.Cells(1, 1))

Sheet4.Select
    Sheet4.Rows("1:1").Select
    Selection.Copy
    Selection.Insert shift:=xlDown
    Cells.Select
    Selection.AutoFilter
    ActiveSheet.Range("$A$1:$A$10000").AutoFilter Field:=1, Criteria1:="="
    Cells.Select
    Selection.Delete shift:=xlUp
    Sheet4.Columns(1).Interior.ColorIndex = xlNone


    Dim FromLine As Integer
    Dim ToLine As Integer
    Dim Count As Integer
    Dim Leng As Integer
    Dim RefTemp, RefTemp1, RefTemp2 As String
    Dim Cha As String
    Dim ReferenceNo As String
    Dim PartNo As String
    Dim Description As String
    Dim Flag As Boolean

    FromLine = 1
    Cha = " "
    While Cells(FromLine, 1) <> ""
        Flag = True
        ReferenceNo = LTrim(Cells(FromLine, 1))
        RefTemp = RTrim(ReferenceNo)
        Leng = Len(RefTemp)
        Cells(FromLine, 1) = RefTemp
        Count = 1
        While Count <= Leng And Flag

            RefTemp1 = Left(ReferenceNo, 1)
            If RefTemp1 <> " " And RefTemp1 <> "," Then

                ReferenceNo = Right(ReferenceNo, Leng - Count)

            Else
                Cells(FromLine, 1) = Left(RefTemp, Count - 1)
                Flag = False
                RefTemp2 = Right(ReferenceNo, Leng - Count)
                'PartNo = Cells(FromLine, 2)
                'Description = Cells(FromLine, 3)
                FromLine = FromLine + 1
                Rows(FromLine).Select
                Selection.Insert shift:=xlDown
                Cells(FromLine, 1) = RefTemp2
                'Cells(FromLine, 2) = PartNo
                'Cells(FromLine, 3) = Description
                FromLine = FromLine - 1
            End If
            Count = Count + 1
        Wend
        FromLine = FromLine + 1

    Wend


    Dim cel1 As Variant
    Dim myrng1 As Range
    Dim clr1 As Long
    Set myrng1 = Sheet4.Range("A1:A" & Sheet4.Range("A65536").End(xlUp).Row)
    myrng1.Interior.ColorIndex = xlNone

    j = 1

    For Each cel1 In myrng1
        If Application.WorksheetFunction.CountIf(myrng1, cel1) > 1 Then
            If WorksheetFunction.CountIf(Sheet4.Range("A1:A" & cel1.Row), cel1) = 1 Then
                'cel1.Interior.ColorIndex = 7
                'cel1.Font.ColorIndex = 1
                Sheet4.Cells(j, 2).Value = cel1
                j = j + 1

            Else
                cel1.Interior.ColorIndex = myrng1.Cells(WorksheetFunction.Match(cel1.Value, myrng1, False), 1).Interior.ColorIndex
            End If
        End If
    Next


Dim lastrow4 As Long
 lastrow4 = Sheet4.Range("B" & Rows.Count).End(xlUp).Row

 Dim myarr() As String

For i = 1 To lastrow4
    For j = 1 To lastrow

        myarr() = Split(Sheet1.Cells(j, 14).Value, ",")

        k1 = 0

        For y = LBound(myarr) To UBound(myarr)
            If myarr(y) = Sheet4.Cells(i, 2).Value Then
                k1 = 1
            End If
        Next y


        'L1 = InStr(Sheet1.Cells(j, 14).Value, Sheet4.Cells(i, 2).Value)
        len1 = Len(Sheet4.Cells(i, 2).Value)



        If Not IsEmpty(Sheet4.Cells(i, 2)) Then
            If k1 > 0 Then
                Start = 1

                Do
                 L1 = InStr(Start, Sheet1.Cells(j, 14).Value, Sheet4.Cells(i, 2).Value)

                If L1 > 0 Then
                    Start = L1 + 1
                    Sheet1.Cells(j, 14).Interior.ColorIndex = 28
                    Sheet1.Cells(j, 14).Characters(L1, len1).Font.ColorIndex = 3
                End If
                Loop While L1 > 0


            End If
        End If
    Next j
Next i
Sheet4.Rows("1:" & Rows.Count).Delete shift:=xlUp


Sheet1.Select

”以识别重复的RDs
表1.列（14）.副本（表4.单元格（1,1））
表4.选择
表4.行（“1:1”）。选择
选择，复制
选择。插入移位：=xlDown
单元格。选择
自动筛选
ActiveSheet.Range（“$A$1:$A$10000”）。自动筛选字段：=1，标准1:=”
单元格。选择
选择。删除移位：=xlUp
表4.列（1）.Interior.ColorIndex=xlNone
将FromLine设置为整数
作为整数的Dim-ToLine
将计数设置为整数
作为整数的Dim Leng
将RefTemp、RefTemp1、RefTemp2标注为字符串
把茶当绳子
作为字符串的Dim ReferenceNo
作为字符串的Dim PartNo
以字符串形式显示的模糊描述
将标志变暗为布尔值
FromLine=1
Cha=“”
While单元格（FromLine，1）”
Flag=True
ReferenceNo=LTrim（单元格（FromLine，1））
参考温度=RTrim（参考温度）
长度=长度（参考温度）
单元格（FromLine，1）=参考温度
计数=1
然后数到1
如果工作表function.CountIf（Sheet4.Range（“A1:A”和cel1.Row），cel1）=1，则
'cel1.Interior.ColorIndex=7
'cel1.Font.ColorIndex=1
表4.单元格（j，2）.值=cel1
j=j+1
其他的
cel1.Interior.ColorIndex=myrng1.Cells（WorksheetFunction.Match（cel1.Value，myrng1，False），1）。Interior.ColorIndex
如果结束
如果结束
下一个
暗淡最后一行4一样长
lastrow4=Sheet4.Range（“B”和Rows.Count）.End（xlUp）.Row
Dim myarr（）作为字符串
对于i=1到最后一行4
对于j=1到最后一行
myarr（）=Split（Sheet1.Cells（j，14）.Value，“”）
k1=0
对于y=LBound（myarr）到UBound（myarr）
如果myarr（y）=4.单元格（i，2）.值，则
k1=1
如果结束
下一个y
L1=InStr（表1.单元格（j，14）.值，表4.单元格（i，2）.值）
len1=Len（表4.单元格（i，2）.值）
如果不是空的（表4.单元格（i，2）），则
如果k1>0，则
开始=1
做
L1=仪表（开始，表1.单元（j，14）.值，表4.单元（i，2）.值）
如果L1>0，则
开始=L1+1
表1.单元格（j，14）.内部颜色索引=28
Sheet1.单元格（j，14）.字符（L1，len1）.Font.ColorIndex=3
如果结束
L1>0时循环
如果结束
如果结束
下一个j
接下来我
Sheet4.行（“1:”&Rows.Count）。删除移位：=xlUp
表1.选择