Conditional Formatting

[chadski778]

I have a selection of cells in my spreadsheet that has a standard number of columns (B-P) but varies in row length in each file. I would like a macro that scans through the contents of each column and returns a summary value in the row below the selection of cells. The priority should be No>Pending>Unknown>Yes

This means that if there is a "No" in the column it would take priority and would be returned in the new row. If there were no cells containg "No" but there was a "Pending" this would be returned and so on. I have added a screenshot for better understanding. The summary of each column should go in the Summary row just below the rows selected. It would be preferable if the output cells could be coloured the same or similar to the ones in the example (No=Red, Unknown and Pending=Orange, Yes=Green)

Excel Workbook
	A	B	C	D	E	F	G	H	I	J	K	L	M	N	O	P
4		EU	ELINCS (EU)	US	Jap	Aus	Can	Kor	Phil	China	NZ	Taiwan	REACh ATIEL Group	REACh overall status	Canadian WHMIS No. & Date	Canadian HMIRC No. & Date
5		Yes	Unknown	Yes	No	Yes	Yes	Yes	Yes	Yes	Yes	Unknown	Unknown	Unknown	Unknown	Unknown
6		Yes	Unknown	Yes	Yes	Yes	Yes	Yes	No	Yes	Yes	Pending	Unknown	Unknown	Unknown	Unknown
7		Yes	Yes	Yes	Yes	Pending	Yes	Yes	Yes	Yes	Yes	Unknown	Unknown	Unknown	Unknown	Unknown
8		Yes	Unknown	Yes	Yes	Yes	Yes	Yes	Unknown	Yes	Yes	Unknown	Unknown	Unknown	Unknown	Unknown
9		Yes	Unknown	Yes	Yes	Unknown	Pending	Yes	Yes	Yes	Yes	Yes	Unknown	Unknown	Unknown	Unknown
10		Yes	Unknown	Yes	Yes	Yes	Pending	Yes	Yes	Yes	Yes	Yes	Unknown	Unknown	Unknown	Unknown
11		Yes	Unknown	Yes	Yes	Yes	Yes	Yes	Pending	Yes	Yes	Yes	Unknown	Unknown	Unknown	Unknown
12	Summary	Yes	Unknown	Yes	No	Pending	Pending	Yes	No	Yes	Yes	Pending	Unknown	Unknown	Unknown	Unknown
Inventories

Thanks

 

[Jerry Sullivan]

Hi chadski778,

You could try this code...

Sub AddSummary()
    Dim lRow As Long, lCol As Long, lItem As Long
    Dim strPriority() As String
    Dim rngSelection As Range, cMatch As Range
    
    Set rngSelection = [B5:P11]  'or use VBA to find data range
    
    Application.ScreenUpdating = False
    strPriority = Split("No;Pending;Unknown;Yes;No matches", ";")
    With rngSelection
        If .Count = 1 Then Exit Sub
        For lCol = 1 To .Columns.Count
            With .Resize(, 1).Offset(0, lCol - 1)
                Debug.Print .Address
                lItem = 0
                Do
                    Set cMatch = .Find(What:=strPriority(lItem), _
                        LookIn:=xlValues, LookAt:=xlWhole)
                    lItem = lItem + 1
                Loop While cMatch Is Nothing And lItem < 5
            End With
            .Cells(.Rows.Count + 1, lCol) = strPriority(lItem - 1)
        Next lCol
    End With
End Sub

For the cell colors, are you currently using Conditional Formatting to get the desired color for each cell in the data range?

If so, you could just add a line to the VBA code to copy-pastespecial formatting to the new row, from the last row in your data range.

 

[chadski778]

Thank you.

It works when if I specify a data range eg (F5:T13) but not if I have the cells selected and just use 'selection' as the criteria. The code stops at If .Count = 1 Then Exit Sub

In VBA, how do I select the newly formed summary row to paste into it the formats from the row above it?

 

[chadski778]

It is not conditionally formatted. I would like to set the "No" values to interior colour 3, "Pending" and "Unknown" to interior colour 44 and "Yes" to interior colour 4. Could you add this to the code please?

 

[Jerry Sullivan]

Try this revised version...

Sub AddSummary()
    Dim lRow As Long, lCol As Long, lItem As Long
    Dim strPriority() As String
    Dim lngColor As Variant
    Dim rngSelection As Range, cMatch As Range
    
    
    Application.ScreenUpdating = False
    strPriority = Split("No;Pending;Unknown;Yes;No matches", ";")
    lngColor = Array(3, 44, 44, 4, 0)
    
    Set rngSelection = Selection
    With rngSelection
        .Resize(1).Offset(.Rows.Count - 1).Copy
        .Resize(1).Offset(.Rows.Count).PasteSpecial (xlFormats)
        
        For lCol = 1 To .Columns.Count
            With .Resize(, 1).Offset(0, lCol - 1)
                lItem = 0
                Do
                    Set cMatch = .Find(What:=strPriority(lItem), _
                        LookIn:=xlValues, LookAt:=xlWhole)
                    lItem = lItem + 1
                Loop While cMatch Is Nothing And lItem < 5
            End With
            With .Cells(.Rows.Count + 1, lCol)
                .Value = strPriority(lItem - 1)
                .Interior.ColorIndex = lngColor(lItem - 1)
            End With
        Next lCol
    End With
End Sub

This line was intended as a check, since it is easy to forget and run the macro without having made a selection.

If .Count = 1 Then Exit Sub

I deleted it based on your comment, but you could add it back in if needed.

 

[chadski778]

Thank you very much. That is excellent!