VBA：查找红色单元格并复制标题
背景：我已经使用'条件'格式来突出显示每一行中的10个最低值。
现在，我正在尝试编写一个代码，用于search每行的红色标记单元格，并将它们的名称从标题行复制到新的表格中。
我的目标是以下内容：一个代码在每行中search红色单元格，并将名称（在标题中）复制到另一个表单（=结果表单）中的同一行。 这应该产生一个包含11列的结果表：第一列是date，该行中的下列10列是该date的最低值的名称。
这是我迄今为止的代码，但它不起作用：
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：截图结果示例
结果示例
我认为你的algorithm应该重新devise：而不是testing单元显示的颜色，检查值是否低于限制。 这个限制可以用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
我认为你的代码应该是这样的：
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不会读取显示的实际颜色，而是将显示没有条件格式的颜色。 所以你需要一辆车来确定显示的颜色。 我基于这个源代码编写了这个代码，但重构了它，例如现在它在国际环境中不起作用，可读性很差：
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语句中的更改（现在它调用上述函数）。
为了澄清我的意见，你需要“推进” 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