Kyle and others,
I have a similar problem I'm experiencing with another piece of tag cloud generating code. My plan is to use Kyle's or something like it for the customer when they have internet available and another one that will work (albeit not as beautifully) when internet isn't available and display both on a sheet called Cloud in sort of a dashboard type presentation. One issue I'm having with this code is I've been unable to successfully display the cloud on the cloud worksheet (sounding similar?). I had a cell on the cloud worksheet that had been formatted for the cloud to appear nicely (merged multiple cells together for one bigger one, with wrapped text, and a thick border). I have a little message which asks where you'd like to place the tag cloud since I was fiddling around a lot to see what it would and would not accept. Low and behold it will only accept a cell on the FreqTable worksheet (which is created to place the pivot table on). Is there any way so that I could get this to display on the same "Cloud" worksheet which now has the tag cloud from Kyle's code?
Sub DoAll()
Dim CloudData As Range
On Error Resume Next
'Asks user to specify which column of data they wish to summarize
Set CloudData = Application.InputBox("Please select a range with the incident information you wish to summarize.", _
"Specify Incident Information", Selection.Address, , , , , 8)
'Sub MakeTable()
Dim Pt As PivotTable
Dim strField As String
'Pass heading to a String variable
'*Need to make edit here most likely with some sort of if to use the first row heading
'if selected data does not include this. i.e. if selected range starts with second row
'or after.*
'strField = Selection.Cells(1, 1).Text
strField = CloudData.Cells(1, 1).Text
'Name the list range not using the xlDown because there exists
'the possibility of blanks in the column data.
'Range(Selection, Selection.End(xlDown)).Name = "Items"
CloudData.Name = "Items"
'Create the Pivot Table based off our named list range.
'TableDestination:="" will force it onto a new sheet
ActiveWorkbook.PivotCaches.Add(SourceType:=xlDatabase, _
SourceData:="=Items").CreatePivotTable TableDestination:="", _
TableName:="ItemList"
'Set a Pivot Table variable to our new Pivot Table
Set Pt = ActiveSheet.PivotTables("ItemList")
'Place the Pivot Table to start from A1 on the new sheet
ActiveSheet.PivotTableWizard TableDestination:=Cells(1, 1)
'Move the list heading to the Row Field
Pt.AddFields RowFields:=strField
'Move the list heading to the Data Field
Pt.PivotFields(strField).Orientation = xlDataField
ActiveSheet.Name = "FreqTable"
'Sorts frequency table descending. *has stopped working since I started tweaking this code I found
' With Range("A1", Cells(Rows.Count, 2).End(xlUp)).Resize(, 2)
' .Sort .Cells(1, 2), xlDescending
' End With
Call CreateCloud
End Sub
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
Range("A1:B1").Select
Range(Selection, Selection.End(xlDown)).Select
Dim size As Integer
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 counter / 2 returns a remainder of 1 i.e. it's a word column then print that "tag"
'
If cntr Mod 2 = 1 Then
taglist = taglist & cell.Value & ", "
tags(i) = cell.Value
'Otherwise (remainder of 0) it must be a frequency count. Set importance(i) to that
'frequency count and set max and min importance (frequency) accordingly
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 G1
'Range("G1").Select
'Ask user to select which cell they would like to place the tag cloud in
Set CloudCell = Application.InputBox("Please select the cell where you'd like to place the word cloud.", _
"Specify Word Cloud Destination", Selection.Address, , , , , 8)
CloudCell.Select
'Sets active cell value to 'taglist' and cell fonts to size 8.
ActiveCell.Value = taglist
ActiveCell.Font.size = 8
'Starting at first character slot within the cell
strt = 1
'Starting at tag 1 to however many tags are contained in the frequency table
For i = 1 To size
'With active cell start changing font size of characters. Applies formatting to
'the appropriate number of characters based on the length of the word (Len(tags(i)).
'*To Change Color must somehow adjust the .ColorIndex portion
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
.ColorIndex = xlAutomatic
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
LinkBack URL
About LinkBacks
JQuery Google Visualizations Intro / Tag (Word) Cloud Generator
Register To Reply
Bookmarks