Question

我有一个代码可以将彩色单元格从动态表格复制到另一个表格我想要做的是在复制单元格之前验证至少有一个红色或黄色单元格。

如果至少有一个红色单元格，则复制标签1中的红色单元格，否则不要复制任何单元格，然后去检查黄色单元格。

如果至少有一个黄色单元格，则在Tab 2中复制黄色单元格，否则退出sub并显示消息“no coloured cells”

Answer 1

使用以下代码并将目标单元格更改为粘贴值

Sub color()
Dim cll As Range
For Each cll In Selection
    If cll.Interior.color = RGB(255, 0, 0) Then
        cll.Copy
        Sheets(2).Range("Destinationcell").PasteSpecial xlPasteValues
    Else
        If cll.Interior.color = RGB(255, 255, 0) Then
            cll.Copy
            Sheets(2).Range("Destinationcell").PasteSpecial xlPasteValues
        Else
            MsgBox ("No Colored Cell")
        End If
    End If
Next
End Sub

您也可以使用以下代码

Sub color()
    Dim cll As Range, i as integer, j as integer
    For Each cll In Selection
        If cll.Interior.color = RGB(255, 0, 0) Then i=i+1
        Else
          If cll.Interior.color = RGB(255, 255, 0) Then j= j +1
          Else
             MsgBox ("No Colored Cell")
          End If
        End IF
        if i>=1 Then
          cll.Copy
          Sheets(2).Range("Destinationcell").PasteSpecial xlPasteValues
        End if
        if j>=1 then
          cll.copy
          Sheets(2).Range("Destinationcell").PasteSpecial xlPasteValues
        End if

    Next
    End Sub

Answer 2

您可以使用下面强大的FindAll函数搜索已格式化的单元格，然后处理结果......

例如。

Sub FindColours()

    Dim FoundRange As Range

    Application.FindFormat.Clear
    Application.FindFormat.Interior.Color = RGB(255, 0, 0)
    Set FoundRange = FindAll("", SearchFormat:=True)
    If Not FoundRange Is Nothing Then
        ' Do Red Cell Stuff
        MsgBox FoundRange.Address
    End If

    Application.FindFormat.Clear
    Application.FindFormat.Interior.Color = RGB(255, 255, 0)
    Set FoundRange = FindAll("", SearchFormat:=True)
    If Not FoundRange Is Nothing Then
        ' Do Yellow Cell Stuff
        MsgBox FoundRange.Address
    End If
End Sub

Function FindAll(What, _
    Optional SearchWhat As Variant, _
    Optional LookIn, _
    Optional LookAt, _
    Optional SearchOrder, _
    Optional SearchDirection As XlSearchDirection = xlNext, _
    Optional MatchCase As Boolean = False, _
    Optional MatchByte, _
    Optional SearchFormat) As Range

    'LookIn can be xlValues or xlFormulas, _
     LookAt can be xlWhole or xlPart, _
     SearchOrder can be xlByRows or xlByColumns, _
     SearchDirection can be xlNext, xlPrevious, _
     MatchCase, MatchByte, and SearchFormat can be True or False. _
     Before using SearchFormat = True, specify the appropriate settings for the Application.FindFormat _
     object; e.g. Application.FindFormat.NumberFormat = "General;-General;""-"""

    Dim SrcRange As Range
    If IsMissing(SearchWhat) Then
        Set SrcRange = ActiveSheet.UsedRange
    ElseIf TypeOf SearchWhat Is Range Then
        Set SrcRange = IIf(SearchWhat.Cells.Count = 1, SearchWhat.Parent.UsedRange, SearchWhat)
    ElseIf TypeOf SearchWhat Is Worksheet Then
        Set SrcRange = SearchWhat.UsedRange
    Else: SrcRange = ActiveSheet.UsedRange
    End If
    If SrcRange Is Nothing Then Exit Function

    'get the first matching cell in the range first
    With SrcRange.Areas(SrcRange.Areas.Count)
        Dim FirstCell As Range: Set FirstCell = .Cells(.Cells.Count)
    End With

    Dim CurrRange As Range: Set CurrRange = SrcRange.Find(What:=What, After:=FirstCell, LookIn:=LookIn, LookAt:=LookAt, _
        SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)

    If Not CurrRange Is Nothing Then
        Set FindAll = CurrRange
        Do
            Set CurrRange = SrcRange.Find(What:=What, After:=CurrRange, LookIn:=LookIn, LookAt:=LookAt, _
            SearchDirection:=SearchDirection, MatchCase:=MatchCase, MatchByte:=MatchByte, SearchFormat:=SearchFormat)
            If CurrRange Is Nothing Then Exit Do
            If Application.Intersect(FindAll, CurrRange) Is Nothing Then
                Set FindAll = Application.Union(FindAll, CurrRange)
            Else: Exit Do
            End If
        Loop
    End If
End Function

验证至少有一个黄色单元格

2 个答案: