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 语句的变化（现在它调用了上述函数）。

Answer 2

我认为应该重新设计您的算法：不要测试单元格显示的颜色，而是检查该值是否低于限制。这个限制可以用 WorksheetFunction.Small 计算，它返回第 n 个最小的元素。

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
    Const lngCount As Long = 10 ' Copy lngCount lowest elements (the actual number may be higher due to ties)
    Const colSort As Long = 2 ' The column in which cells contain the values from which the lowest lngCount should be selected

    Dim varLimit As Variant: varLimit = Application.WorksheetFunction.Small(sPrice.UsedRange.Cells(2, colSort).Resize(sPrice.UsedRange.Rows.Count - 1, 1), 10)
    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 sPrice.Cells(rowPrice, colSort).Value <= varLimit Then
            sResult.Cells(rowResult, colResult).Value = sPrice.Cells(rowPrice, colPriceName).Value
            rowResult = rowResult + 1
        End If
    Next rowPrice
End Sub

根据截图，我修改了代码：

Sub CopyReds()
    Dim sPrice As Worksheet: Set sPrice = Sheets("Prices")
    Dim sResult As Worksheet: Set sResult = Sheets("Result")
    Const rowResultFirst As Long = 2 ' First row on sResult to use for output
    Const rowPriceFirst As Long = 2 ' First row on sPrice to process
    Const lngCount As Long = 10 ' Copy lngCount lowest elements (the actual number may be higher due to ties)
    Const colDate As Long = 1 ' The column which contains the dates
    Const colValueStart As Long = 2 ' The column where values start

    Dim rowResult As Long: rowResult = rowResultFirst
    Dim rowPrice As Long: For rowPrice = rowPriceFirst To sPrice.UsedRange.Rows.Count - sPrice.UsedRange.Row + 1 ' Loop until last row
        Dim colResult As Long: colResult = 1
        sResult.Cells(rowResult, colResult).Value = sPrice.Cells(rowPrice, colDate).Value
        colResult = colResult + 1
        Dim varLimit As Variant: varLimit = Application.WorksheetFunction.Small(sPrice.Cells(rowPrice, colValueStart).Resize(1, sPrice.UsedRange.Columns.Count - colValueStart + 1), lngCount)
        Dim colPrice As Long: For colPrice = colValueStart To sPrice.UsedRange.Columns.Count - colValueStart + 1
            If sPrice.Cells(rowPrice, colPrice).Value <= varLimit Then
                sResult.Cells(rowResult, colResult).Value = sPrice.Cells(rowResultFirst - 1, colPrice).Value
                colResult = colResult + 1
            End If
        Next colPrice
        rowResult = rowResult + 1
    Next rowPrice
End Sub

Answer 3

为了澄清我的评论，您需要“提前”Cells(j, i) 或 Offset(j, 0)。

如果您决定使用For 循环，请尝试在这两种情况下都使用它：，请参见下面的代码：

For j = 2 To 217
    For i = 2 To 1086
        Debug.Print sPrice.Cells(j, i).Interior.Color ' <-- for Debug only
        If sPrice.Cells(j, i).Interior.Color = 13551615 Then
            sPrice.Cells(j, i).Copy Destination:=sResult.Cells(2, 2).Offset(j, 1)
        End If
    Next i
Next j