Conditional Formatting Word Cloud

[HughT]

My boss has seen a word cloud and now wants me to create one (in Excel 2003).

Problem, I can't use Wordle for security reasons. Partial solution - I have used the (mighty!) Chandoo's solution to create a cell populated with words with font size based on frequency of use. However Chandoo's solution is one colour only, ie whatever the cell font colour is.

Is there a way, perhaps using Conditional Formatting, to select words from the table and use this data as the basis for the formula within a Conditional Format? eg if the table / cloud contains 'Cat, Dog, Mouse, Smith, Munroe, Adams, Cheese, Bread, Apple' is it possible to colour (for example) 'Cat' , 'Dog' and 'Mouse' in blue, 'Smith', 'Munroe', 'Adams' in red , 'Cheese', 'Bread', 'Apple' in green?

Alternatively a user could select the parameters based on the value against any other specified criteria eg Cat, Adams and Bread score below 20 = green, Dog and Cheese between 21 and 40 = blue, Mouse, Smith, Munroe and Apple over 41 = red.

Any thoughts gratefully received!


HughT

 

[Andrew Poulsom]

You won't be able to use Conditional Formatting because that applies to the entire cell. But you could add some colouring code to Chandoo's macro. And here is another possibility:

http://www.howtodothings.com/video/how-to-make-a-pivot-tag-cloud-on-excel

 

[HughT]

Andrew

Many thanks for your prompt reply - problem is, for the same reasons we can't use Wordle, we can't stream videos either (they are very security conscious here!).

How would I add colouring code to Chandoo's macro? I did try various things but it defeated me, being a bit of a VBA newbie.

 

[Andrew Poulsom]

Try:

Sub createCloud()
'   this subroutine creates a tag cloud based on the list format tagname, tag importance
'   the tag importance can have any value, it will be normalized to a value between 8 and 20
 
    On Error GoTo tackle_this
 
    Dim size As Integer
    Dim cntr As Long
    Dim i As Long
    Dim Cell As Range
    Dim taglist As String
    Dim strt As Long
    size = Selection.Count / 2
 
    Dim tags() As String
    Dim importance()
 
    ReDim tags(1 To size) As String
    ReDim importance(1 To size)
 
    Dim minImp As Integer
    Dim maxImp As Integer
 
    cntr = 1
    i = 1
 
    For Each Cell In Excel.Selection
        If cntr Mod 2 = 1 Then
            taglist = taglist & Cell.Value & ", "
            tags(i) = Cell.Value
        Else
            importance(i) = Val(Cell.Value)
            If importance(i) > maxImp Then
                maxImp = importance(i)
            End If
            If importance(i) < minImp Then
                minImp = importance(i)
            End If
            i = i + 1
        End If
        cntr = cntr + 1
    Next Cell
 
'   paste values in cell e10
    Range("e10").Select
    ActiveCell.Value = taglist
    ActiveCell.Font.size = 8
 
    strt = 1
 
    For i = 1 To size
 
        With ActiveCell.Characters(Start:=strt, Length:=Len(tags(i))).Font
            .size = 6 + Math.Round((importance(i) - minImp) / (maxImp - minImp) * 14, 0)
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            Select Case tags(i)
                Case "Cat", "Dog", "Mouse"
                    .ColorIndex = 5
                Case "Smith", "Munroe", "Adams"
                    .ColorIndex = 3
                Case "Cheese", "Bread", "Apple"
                    .ColorIndex = 10
            End Select
        End With
        strt = strt + Len(tags(i)) + 2
    Next i
    Exit Sub
tackle_this:
'   errors handled here
    MsgBox "You need to select a table so that I can create a tag cloud", vbCritical + vbOKOnly, "Wow, looks like there is an error!"
 End Sub

 

[HughT]

Thank you very much indeed! This is absolutely fantastic!

 

[HughT]

Andrew

At the risk of being really annoying, but here goes....

As this stands, the user has to select a range of cells with the mouse, and it is not possible to change the colour settings without going into the code and changing them there, the first of which isn't automatic, and the second beyond ordinary users.

Firstly, would it be possible to have a fixed range for the values, eg D1:E10 (text in D, values in E?) This means that it would be possible for these values to be derived from any other source, eg list of football scores, stock list etc.

Secondly, would it be possible to have the colour values based on cell references, eg D1:D5 red, D6:D8 blue (or whatever)? Currently they are based on actual text strings (eg 'Cat' 'Cheese' etc) in the code which a user couldn't change. This would mean that irrespective of whatever text is in in D1 etc, it would be coloured appropriately.

Thirdly, (and I realise I am really sticking my neck out here!) would it be possible to change the colour code settings from another table rather than from within the code itself? This means that a user could also specify the colours.

And since I am going for broke, can the font size variable also be set from outside the code?

I am really sorry I don't know how to do this myself (yet - still a VBA newbie I am afraid) but I think that this would make a really useful tool for others to use as all the variables could be set externally.

 

[Andrew Poulsom]

Here's a start:

Sub createCloud()
'   this subroutine creates a tag cloud based on the list format tagname, tag importance
'   the tag importance can have any value, it will be normalized to a value between 8 and 20
 
    On Error GoTo tackle_this
    Dim Rng As Range
    Dim size As Integer
    Dim cntr As Long
    Dim i As Long
    Dim Cell As Range
    Dim taglist As String
    Dim strt As Long
    Set Rng = ActiveSheet.Range("D1:E10")
    size = Rng.Count / 2
    Dim tags() As String
    Dim importance()
    ReDim tags(1 To size) As String
    ReDim importance(1 To size)
    Dim minImp As Integer
    Dim maxImp As Integer
    cntr = 1
    i = 1
    For Each Cell In Rng
        If cntr Mod 2 = 1 Then
            taglist = taglist & Cell.Value & ", "
            tags(i) = Cell.Value
        Else
            importance(i) = Val(Cell.Value)
            If importance(i) > maxImp Then
                maxImp = importance(i)
            End If
            If importance(i) < minImp Then
                minImp = importance(i)
            End If
            i = i + 1
        End If
        cntr = cntr + 1
    Next Cell
'   paste values in cell F11
    Range("F11").Select
    ActiveCell.Value = taglist
    ActiveCell.Font.size = 8
    strt = 1
    For i = 1 To size
        With ActiveCell.Characters(Start:=strt, Length:=Len(tags(i))).Font
            .size = 6 + Math.Round((importance(i) - minImp) / (maxImp - minImp) * 14, 0)
            .Strikethrough = False
            .Superscript = False
            .Subscript = False
            .OutlineFont = False
            .Shadow = False
            .Underline = xlUnderlineStyleNone
            Select Case i
                Case 1 To 5
                    .ColorIndex = 5
                Case 6 To 8
                    .ColorIndex = 3
                Case Else
                    .ColorIndex = 10
            End Select
        End With
        strt = strt + Len(tags(i)) + 2
    Next i
    Exit Sub
tackle_this:
'   errors handled here
    MsgBox "You need to select a table so that I can create a tag cloud", vbCritical + vbOKOnly, "Wow, looks like there is an error!"
 End Sub

 

[HughT]

Wow!

Thanks to you, my boss thinks I am great!! (I did tell her I got someone else to do it for me though!)