VBA:查找红色单元格并复制标题

Question

背景:我已经使用“条件”格式以浅红色突出显示每行中的 10 个最低值。

现在，我正在尝试编写一个代码，在每一行中搜索红色标记的单元格，并将它们的名称从标题行复制到新工作表中。

我的目标如下:在每一行中搜索红色单元格并将名称(在标题中)复制到另一张表(=结果表)中的同一行的代码。这将产生一个包含 11 列的结果表:第一列是日期，该行中接下来的 10 列是该日期最低值的名称。

这是我到目前为止的代码，但它不起作用:

Sub CopyReds()

Dim i As Long, j As Long

Dim sPrice As Worksheet
Dim sResult As Worksheet

Set sPrice = Sheets("Prices")
Set sResult = Sheets("Result")

i = 2
For j = 2 To 217
    Do Until i = 1086
        If sPrice.Cells(j, i).Offset(j, 0).Interior.Color = 13551615 Then
            sPrice.Cells(j, i).Copy Destination:=sResult.Cells(2, 2).Offset(j, 1)
        End If
    Loop
Next j

End Sub

更新:截图工作表



更新 2:截图结果示例

Answer 1

我认为您的代码应如下所示:

Option Explicit

Sub CopyReds()
    Dim sPrice As Worksheet: Set sPrice = Sheets("Prices")
    Dim sResult As Worksheet: Set sResult = Sheets("Result")
    Const colPriceName As Long = 2 ' The column in which cells can be colored red and contains the names to copy
    Const clrCopy As Long = 13551615 ' The color which indicates that the cell should be copied (red)
    Const colResult As Long = 2 ' The column where the results should be copied
    Const rowResultFirst As Long = 2 ' First row on sResult to use for output

    Dim rowResult As Long: rowResult = rowResultFirst
    Dim rowPrice As Long: For rowPrice = 2 To sPrice.UsedRange.Rows.Count - sPrice.UsedRange.Row + 1 ' Loop until last row
        If DisplayedColor(sPrice.Cells(rowPrice, colPriceName)) = clrCopy Then
            sResult.Cells(rowResult, colResult).Value = sPrice.Cells(rowPrice, colPriceName).Value
            rowResult = rowResult + 1
        End If
    Next rowPrice
End Sub

更新:处理条件格式

如果您使用条件格式，则 VBA 不会读取显示的实际颜色，而是会在没有条件格式的情况下显示的颜色。所以你需要一个车辆来确定显示的颜色。我根据 this source 编写了这段代码但对其进行了重大重构，例如现在它在国际环境中不起作用，可读性很差:

Function DisplayedColor(rngCell As Range, Optional bCellInterior As Boolean = True, Optional bReturnColorIndex As Long = False) As Long
    Dim ewbTemp As Workbook: Set ewbTemp = Application.Workbooks.Add() ' Creates a new workbook, so that none of the cells of other workbooks is tampered with (not even temporarily) - this may be overkill, you may centralize this object or use existing cells
    DisplayedColor = -1 ' Assume Failure and indicate Error
    If 1 < rngCell.Count Then
        Debug.Print "Error in DisplayedColor: rngCell contains more than 1 cell"
        Exit Function
    End If
    Dim objTarget As Object: Set objTarget = rngCell
    Dim i As Long: For i = 1 To rngCell.FormatConditions.Count
        With rngCell.FormatConditions(i)
            Dim bFormatConditionActive As Boolean: bFormatConditionActive = False
            Dim varValue As Variant: varValue = rngCell.Value
            Dim strFormula1 As String: strFormula1 = FormulaFromFormulaLocal(.Formula1, ewbTemp.Worksheets(1).Cells(1, 1))
            Dim varEval1 As String: varEval1 = rngCell.Worksheet.Evaluate(strFormula1)
            If .Type = xlCellValue Then
                Select Case .Operator
                    Case xlEqual
                        bFormatConditionActive = varValue = varEval1
                    Case xlNotEqual
                        bFormatConditionActive = varValue <> varEval1
                    Case xlGreater
                        bFormatConditionActive = varValue > varEval1
                    Case xlGreaterEqual
                        bFormatConditionActive = varValue >= varEval1
                    Case xlLess
                        bFormatConditionActive = varValue < varEval1
                    Case xlLessEqual
                        bFormatConditionActive = varValue <= varEval1
                    Case xlBetween, xlNotBetween
                        Dim strFormula2 As String: strFormula2 = FormulaFromFormulaLocal(.Formula2, ewbTemp.Worksheets(1).Cells(1, 1))
                        Dim varEval2 As String: varEval2 = rngCell.Worksheet.Evaluate(strFormula2)
                        bFormatConditionActive = varEval1 <= varValue And varValue <= varEval2
                        If .Operator = xlNotBetween Then
                            bFormatConditionActive = Not bFormatConditionActive
                        End If
                    Case Else
                        Debug.Print "Error in DisplayedColor: unexpected Operator"
                        Exit Function
                End Select
            ElseIf .Type = xlExpression Then
                bFormatConditionActive = varEval1
            Else
                Debug.Print "Error in DisplayedColor: unexpected Type"
                Exit Function
            End If
            If bFormatConditionActive Then
                Set objTarget = rngCell.FormatConditions(i)
                Exit For
            End If
        End With
    Next i
    If bCellInterior Then
        If bReturnColorIndex Then
            DisplayedColor = objTarget.Interior.ColorIndex
        Else
            DisplayedColor = objTarget.Interior.Color
        End If
    Else
        If bReturnColorIndex Then
            DisplayedColor = objTarget.Font.ColorIndex
        Else
            DisplayedColor = objTarget.Font.Color
        End If
    End If
    ewbTemp.Close False
End Function

Function FormulaFromFormulaLocal(strFormulaLocal As String, rngDummy As Range) As String
    Dim strOldFormula As String: strOldFormula = rngDummy.Formula
    rngDummy.FormulaLocal = strFormulaLocal
    FormulaFromFormulaLocal = rngDummy.Formula
    rngDummy.Formula = strOldFormula
End Function

另请注意 CopyReds 的 If 语句的变化(现在它调用上述函数)。