VBA: Find red cells and copy header - vba

Question

Background: I have already used the 'conditional' formatting to highlight the 10 lowest values in each row in light red.
Now, I am trying to compose a code that searches each row for the red marked cells and copies their name from the header row to a new sheet.
What I am aiming for is the following: a code that searches each row for the cells in red and that copies the name (in header) to the same row in another sheet (=result sheet). This should result in a result sheet with 11 columns: first column being the dates and the following 10 columns in that row being the names of the lowest values for that date.
This is the code that I have so far but it does not work:
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
Update: screenshot worksheet
Update 2: Screenshot result sample

Answer 1

I think your code should look something like this:
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
Update: handling conditional formatting
If you use conditional formatting then VBA does not read the actual color displayed but the color which would be shown without Conditional Formatting. So you need a vehicle to determine the displayed color. I wrote this code based on this source but refactored it significantly, e.g. now it did not work in international environment and its readability was poor:
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
Please also note the change in the If statement of CopyReds (now it calls the above function).

Answer 2

I think that your algorithm should be redesigned: instead of testing the cells displayed color, check if the value is below a limit. This limit can be calculated with WorksheetFunction.Small, which returns the n-th smallest element.
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
Based on the screenshots, I revised the code:
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

Just to clarify my comment, you need to "advance" either the Cells(j, i) or the Offset(j, 0).
If you decided to use For loops, try to stick with it for both cases:, see code below:
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