请各位老师帮助！！在某个单元格包含特定文本时，自动高亮多行 ，项目已经过拆分

t2019er

1.查找所有sheets中是否包含样品编号（或者各个子表的H3单元格是否包含样品编号），存在时在c列备注；
2.在对应样品编号的子表中查找b列项目名是否存在。存在时，高亮该项目占用的17行（往前取11行，往后取5行）；
3.高亮所有子表1-8行；
4.删除所有子表没有高亮的行；
5.取消所有子表行的高亮；
6.完成。

sam-wang

請測試看看，謝謝

t2019er

sam-wang 发表于 2022-5-31 20:32
請測試看看，謝謝

文件损坏，无法解压

t2019er

我自己尝试着写到，实现到第三步，第四部下不去l

   Sub test()
Dim I As Integer
Dim j As Integer
Dim k As Integer
Dim s As Integer
Dim r As Integer
Dim lastrow As Integer
For I = 2 To 200 'sheets（i）子表名
For j = 2 To 200 'sheets（1）A列查样品编号
  If Sheets(I).Cells(3, "h") = Sheets(1).Cells(j, "a") Then
     Sheets(1).Cells(j, "c") = "存在"
     Sheets(1).Cells(j, "c").Interior.ColorIndex = 6
       For k = 21 To 2000 Step 18 ' sheets（i）子表查项目

          If IsError(Application.Find(Sheets(1).Cells(j, "b"), Sheets(I).Cells(k, "a"), 1)) Then  ' sheets（i）子表项目不在Sheets(i).Cells(k, "a")

          Else
            'sheets（i）子表项目在Sheets(i).Cells(k, "a")时高亮

            Sheets(I).Cells(k, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(k - 1, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(k - 2, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(k - 3, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(k - 4, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(k - 5, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(k - 6, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(k - 7, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(k - 8, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(k - 9, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(k - 10, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(k - 11, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(k + 1, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(k + 2, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(k + 3, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(k + 4, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(k + 5, "a").Interior.ColorIndex = 6

            Sheets(I).Cells(1, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(2, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(3, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(4, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(5, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(6, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(7, "a").Interior.ColorIndex = 6
            Sheets(I).Cells(8, "a").Interior.ColorIndex = 6


            Sheets(1).Cells(j, "d") = "存在"

          End If
         Next

     Else
   End If
Next
Next

End Sub

t2019er

第四步，用这个可以删除单个sheet，多个搞不出来
Sub 删除颜色的行()
Dim I%
For I = Range("A65536").End(xlUp).Row + 1 To 2 Step -1
If Cells(I, "A").Interior.ColorIndex <> 6 Then
Rows(I).Delete
End If
Next
MsgBox "完毕........"
End Sub

sam-wang

t2019er 发表于 2022-5-31 21:49
文件损坏，无法解压

貼上程式碼，請測試看看，謝謝
Sub test()
Dim Arr, Brr, xD, xD1, T$, i&, sh, R&, xR As Range, xU As Range
Set xD = CreateObject("Scripting.Dictionary")
Set xD1 = CreateObject("Scripting.Dictionary")
Application.ScreenUpdating = False
For Each sh In Sheets
    If InStr(sh.Name, "品") Then GoTo 95
    T = Split(sh.Name, "_")(1): xD(T) = ""
95: Next
With Sheet1
    Arr = .[a1].CurrentRegion
    For i = 2 To UBound(Arr)
        T = Arr(i, 1): xD1(Arr(i, 2) & "") = ""
        If xD.Exists(T) Then Arr(i, 3) = "Yes" Else Arr(i, 3) = "No"
    Next
    .[a1].Resize(UBound(Arr), 3) = Arr
End With
For sh = 2 To Sheets.Count
    With Sheets(sh)
        Brr = .Range(.[a1], .[a65536].End(3))
        For i = 1 To UBound(Brr)
            If i = 1 Then .Range(.Cells(i, 1), .Cells(i + 8, 10)).Interior.ColorIndex = 8
            For i1 = 2 To UBound(Arr)
                If InStr(Brr(i, 1), Arr(i1, 2)) Then
                    .Range(.Cells(i - 12, 1), .Cells(i + 5, 10)).Interior.ColorIndex = 8
                End If
            Next
        Next
    End With
Next
For sh = 2 To Sheets.Count
    Sheets(sh).Select
    With Sheets(sh)
        R = .Cells(.Rows.Count, 1).End(3).Row
        For Each xR In .Range(.[a1], .Cells(R, 1))
             Clr = xR.DisplayFormat.Interior.ColorIndex
            If Not Clr <> -4142 Then
                If xU Is Nothing Then Set xU = xR Else Set xU = Union(xR, xU)
            End If
        Next
        If Not xU Is Nothing Then xU.EntireRow.Delete
        .Range(.Cells(1, 10), .Cells(R, 1)).Interior.ColorIndex = -4142
    End With
    Set xU = Nothing
Next
Sheets(1).Select
Application.ScreenUpdating = True
End Sub

sam-wang

t2019er 发表于 2022-5-31 21:54
第四步，用这个可以删除单个sheet，多个搞不出来
Sub 删除颜色的行()
Dim I%

附上執行過程圖片，謝謝

t2019er

sam-wang 发表于 2022-6-1 07:33
附上執行過程圖片，謝謝

多谢您提供帮助！

我发现代码执行后几个子表里的项目都是一样的，没有达到效果。

还有每个表的末尾都多了行。

t2019er

t2019er 发表于 2022-5-31 21:52
我自己尝试着写到，实现到第三步，第四部下不去l

   Sub test()