Adding Formulae and Arrows to Macro

[RichJW]

Hi all,

I hope you can help with this. I’ll try to explain as well as I can.

I’ve a macro based report pulling in data from numerous spreadsheets into one.

In my “Values” tab, I have data in columns D and E, which equal either Red, Amber, Green or Blue. This data starts from row 2 in each column, but the end row changes each week with the amount of data pulled in (columns A, B, D, E will always have data in them).

I wish to compare the number of Reds in column D with the number of Reds in column E, the number of Ambers in column D with the number of Ambers in E, etc. for Green and Blue as well.
Ideally, then I would like to have Red/Green arrows to indicate whether the amount in column D is greater or less than that in E for each of the 4 colours.

I’m having problems inputting formulas into the macro, as I have only inputted text before, so it shows the “=countif” text rather than the formula.

Have any of you wonderful, knowledgeable people got any jazzy idea as to how this can be made to work and look good?

Thanks,
Rich

 

[Roderick_E]

When you say columns D & E contains Red, Amber, Green, or Blue; are you saying this is text in those columns or the cell color or what?

 

[RichJW]

Hi Roderick,

Both. It shows the text "Red", "Green" etc, then the cell is coloured the same colour.

Thanks,
Rich

 

[Roderick_E]

Hi Rich, in this case could put 4 rows above where the data starts, a row for each color and then use code like this:

="RED="&COUNTIF(D3:D65536,"red")

Obviously "Blue"= and so on. Unless you anticipate more that 65536 rows this would work for new additions.

 

[Yongle]

Here is some VBA to get you started
- paste into a new standard module

A worksheet is added containing a small table based on values in columns D & E of sheet "Values"

Private countE As Integer, countD As Integer    'must be above all procedures in module

Sub Test()
    Dim r As Long, colour As Variant, colD As Range, colE As Range
    Set colD = Sheets("Values").Range("D:D")
    Set colE = colD.Offset(, 1)
    r = 1
    Set ws = Worksheets.Add
    ws.Range("B1:D1").Value = Array("D", "E", "Icon")
    
    For Each colour In Array("Red", "Amber", "Green", "Blue")
        r = r + 1
        With WorksheetFunction
            countD = .CountIf(colD, colour)
            countE = .CountIf(colE, colour)
        End With
            
        With ws
            .Cells(r, 1) = colour
            .Cells(r, 2) = countD
            .Cells(r, 3) = countE
            Call AddArrow(.Cells(r, 4))
        End With
    Next
    ws.Cells(1).CurrentRegion.HorizontalAlignment = xlCenter
End Sub

Private Sub AddArrow(cel As Range)
    Dim f As Variant, c As String
    Select Case countD
        Case Is = countE
            f = vbBlack
            c = Chr(134)
        Case Is > countE
            f = vbGreen
            c = Chr(230)
        Case Is < countE
            f = vbRed
            c = Chr(230)
    End Select
    
    With cel
        .Font.Name = "Wingdings 3"
        .Font.Color = f
        .Value = c
    End With
    
End Sub

 

[RichJW]

Thanks Roderick_E, that's a smart little trick.

 

[RichJW]

Thanks Yongle, that looks really good.

Instead of adding it to a new sheet, how could I get the macro to paste it into the next available cell in column F of the Values tab?
Thanks,
Rich

 

[Yongle]

Replace Test1 with this

Sub Test2()
    Dim rr As Long, r As Long, colour As Variant, colD As Range, colE As Range, ws As Worksheet
    Set ws = Sheets("Values")
    Set colD = ws.Range("D:D")
    Set colE = colD.Offset(, 1)
    rr = ws.Range("F" & Rows.Count).End(xlUp).Row + 1
    r = rr
    For Each colour In Array("Red", "Amber", "Green", "Blue")
        r = r + 1
        With WorksheetFunction
            countD = .CountIf(colD, colour)
            countE = .CountIf(colE, colour)
        End With
            
        With ws
            .Cells(r, 3) = colour
            .Cells(r, 4) = countD
            .Cells(r, 5) = countE
            Call AddArrow(.Cells(r, 6))
        End With
    Next
    ws.Cells(rr, 3).CurrentRegion.HorizontalAlignment = xlCenter
End Sub

 

[RichJW]

Thanks Yongle - fantastic!
Appreciate your help.

Cheers,
Rich