Question

我正在此网站上找到我正在使用的这段代码，在此方面我已经寻求帮助，但是它并不能完全满足我的需要。

我有2张纸“生产”和“组件”。 “生产”是一个数据列表，其中包括一列工作编号（B）。 “组件”是一列基于不同位置的列，在下面的单元格中是作业编号。

我需要将“组件”上数字的单元格背景色与“生产”表上相同值的单元格背景色相匹配的代码。

下面的代码可以做到这一点，但是有两个问题。

首先，它搜索“生产”中的整个列（B），该列通常可以重复相同的编号。我只需要搜索它，直到找到从工作表顶部找到的第一个实例。

第二，当宏运行时，花一些时间才能检查所有数字，如果可以的话，我需要更快的方法吗？

Sub Worksheet_Update()
  Dim wsHighlight As Worksheet
  Dim wsData As Worksheet
  Dim rngColor As Range
  Dim rngFound As Range
  Dim KeywordCell As Range
  Dim strFirst As String

  Set wsHighlight = Sheets("Production")
  Set wsData = Sheets("Components")

  With wsData.Columns("A:M")
    For Each KeywordCell In wsHighlight.Range("B3", wsHighlight.Cells(Rows.Count, "B").End(xlUp)).Cells
      Set rngFound = .Find(KeywordCell.Text, .Cells(.Cells.Count), xlValues, xlWhole)
      If Not rngFound Is Nothing Then
        strFirst = rngFound.Address
        Set rngColor = rngFound
        Do
          Set rngColor = Union(rngColor, rngFound)
          Set rngFound = .Find(KeywordCell.Text, rngFound, xlValues, xlWhole)
        Loop While rngFound.Address <> strFirst
        rngColor.Interior.Color = KeywordCell.Interior.Color
      End If
    Next KeywordCell
  End With
End Sub

Answer 1

原始代码中有一个缺陷。 “在While中查找”应该是FindNext。

...
Do
    Set rngColor = Union(rngColor, rngFound)
    Set rngFound = .FindNext(after:=rngFound)  '<~~ here
Loop While rngFound.Address <> strFirst
...

重写：

Option Explicit

Sub Worksheet_Update()

    Dim rngColor As Range, rngFound As Range
    Dim KeywordCell As Range, HighlightRange As Range
    Dim strFirst As String, i as long, arr as variant

    redim arr(i)

    With Worksheets("Production")
        Set HighlightRange = .Range(.Cells(3, "B"), .Cells(.Rows.Count, "B").End(xlUp))
    End With

    With Worksheets("Components").Columns("A:M")
        For Each KeywordCell In HighlightRange
            if iserror(application.match(KeywordCell.Text, arr, 0)) then
                Set rngFound = .Find(KeywordCell.Text, .Cells(.Cells.Count), xlValues, xlWhole)
                If Not rngFound Is Nothing Then
                    strFirst = rngFound.Address
                    Set rngColor = rngFound
                    Do
                        Set rngColor = Union(rngColor, rngFound)
                        Set rngFound = .FindNext(after:=rngFound)
                    Loop While rngFound.Address <> strFirst
                    rngColor.Interior.Color = KeywordCell.Interior.Color
                End If
                redim preserve arr(i)
                arr(i) = KeywordCell.Text
                i=i+1
            end if
        Next KeywordCell
    End With
End Sub

excel公式匹配单元格背景色

1 个答案: