Thematic mapping bitly links with Excel and Google charts.
I have created some SAP barcode device types that can be downloaded for free. See this
link for my SAP Barcode device types Using the BIT.LY service for these downloads I do know that they have been downloaded in many countries. So as I do have an interest in thematic maps I decided to put the BITLY statistics on a map.
Currently the countries that have accessed my barcode related links looks like this.
The above Google map chart was created using an Excel macro as follows.
Screen shot of the final Excel sheet.
Creating the Chart Map
1) BitLy API Key
First I registed for a BitLy API key here
Logon with your BitLy account and the API key will be displayed.
2) Excel Setup
Changes required
From step 1 you should have a bitly userid and api key, enter these values in the following cells.
Change filenames of the CSV and XLS files to be saved, currently C:\ZBWIPPgooglechart.
Change the names under URL to the bit.ly links of you want to put on a map.
Run the macro "runbitly" to produce the Google chart maps.
This will then produce two files, one csv file and one xls file. The xls file will contain the Google map charts.
Extract of all the macro code involved.
Public fXLS As String
Sub runbitly()
DI = Range("FILE").Value
fXLS = Range("XLS").Value
getbitlystats
gettotals
chartg
End Sub
Sub gettotals()
'
' gettotals Macro
'
'
DI = Range("FILE").Value
Sheets("DATA").Select
Columns("D:P").Select
Selection.Delete Shift:=xlToLeft
Range("A1").Select
rr = Range("A1").End(xlDown).Row
Range(Cells(1, 1), Cells(rr, 3)).Select
Range(Cells(1, 1), Cells(rr, 3)).Sort Key1:=Range("C2"), Order1:=xlAscending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
Selection.Subtotal GroupBy:=3, Function:=xlSum, TotalList:=Array(1), _
Replace:=True, PageBreaks:=False, SummaryBelowData:=True
Range("A1").Select
rr = Range("A1").End(xlDown).Row
ActiveSheet.Outline.ShowLevels RowLevels:=2
' Selection.SpecialCells(xlCellTypeVisible).Select
Range(Cells(1, 1), Cells(rr, 3)).SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Workbooks.Add
ActiveSheet.Paste
Selection.Replace What:=" Total", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Columns("B:B").Select
Application.CutCopyMode = False
Selection.Delete Shift:=xlToLeft
Range("A1").Select
'remove grand totol
Range("A1").End(xlDown).Select
Rows(ActiveCell.Row & ":" & ActiveCell.Row).Select
Selection.Delete Shift:=xlUp
Range("A1").Select
rr = Range("A1").End(xlDown).Row
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:= _
DI, _
FileFormat:=xlCSV, CreateBackup:=True
Application.DisplayAlerts = True
End Sub
Sub chartg()
totcont = 0
Range("A1").Select
rr = Range("A1").End(xlDown).Row
For i = 2 To rr
If Cells(i, 2) <> "None" Then
If i = 2 Then
totcont = totcont + 1
country = Cells(i, 2).Value
clicks = Cells(i, 1).Value
Else
totcont = totcont + 1
country = country & Cells(i, 2).Value
clicks = clicks & "," & Cells(i, 1).Value
End If
End If
Next i
UR1 = "http://chart.apis.google.com/chart"
'UR1 = UR1 & "?chf=bg,s,EAF7FE"
UR1 = UR1 & "?chs=440x220"
UR1 = UR1 & "&cht=t"
'UR1 = UR1 & "&chco=FFFFFF,FF0000,FFFF00,00FF00"
'UR1 = UR1 & "&chld=BWCFCGCVDJDZEGGHKEMGMZNGSNTZZM"
UR1 = UR1 & "&chld=" & country
'UR1 = UR1 & "&chd=t:60,43,14,54,17,0,100,76,12,50,18,40,98,70,29"
UR1 = UR1 & "&chd=t:" & clicks
UR2 = UR1 & "&chtm=europe"
UR3 = UR1 & "&chtm=south_america"
UR4 = UR1 & "&chtm=asia"
UR1 = UR1 & "&chtm=world"
Cells(1, 3).Value = totcont & " Total Countries"
Cells(1, 3).Select
With Selection.Font
.Name = "Arial"
.Size = 14
.Bold = True
.ColorIndex = xlAutomatic
End With
Cells(3, 3).Value = UR1
Cells(4, 3).Value = UR2
Cells(5, 3).Value = UR3
Cells(6, 3).Value = UR4
Range("A1").Select
rr = Range("A1").End(xlDown).Row
Range("A1").Select
Range(Cells(1, 1), Cells(rr, 2)).Sort Key1:=Range("A2"), Order1:=xlDescending, Header:= _
xlGuess, OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
DataOption1:=xlSortNormal
'
Range("C5").Select
ActiveSheet.Pictures.Insert( _
UR1 _
).Select
Range("K5").Select
ActiveSheet.Pictures.Insert( _
UR2 _
).Select
Range("C20").Select
ActiveSheet.Pictures.Insert( _
UR3 _
).Select
Range("K20").Select
ActiveSheet.Pictures.Insert( _
UR4 _
).Select
Application.DisplayAlerts = False
ActiveWorkbook.SaveAs Filename:= _
fXLS, _
FileFormat:=xlNormal, CreateBackup:=True
Application.DisplayAlerts = True
End Sub
Sub getbitlystats()
' FR = ActiveSheet.ActiveCell.End(xlDown).Row
Sheets("DATA").Select
Cells.Select
Selection.Delete Shift:=xlUp
Range("A1").Select
Sheets("URLs").Select
c = 2
While ActiveSheet.Cells(c, 3).Value <> ""
' MsgBox ActiveSheet.Cells(c, 3).Value
Sheets("URLs").Select
UR = ActiveSheet.Cells(c, 3).Value
AUR = "FINDER;" + UR
DI = Range("Dir").Value
FI = ActiveSheet.Cells(c, 1).Value
' MsgBox UR
' MsgBox DIFIC
Sheets("DATA").Select
Cells(1, 1).Select
If Cells(1, 1).Value <> "" Then
Range("A1").End(xlDown).Offset(1, 0).Select
d = Range("A1").End(xlDown).Offset(1, 0).Row
Else
d = 1
End If
With ActiveSheet.QueryTables.Add(Connection:= _
AUR _
, Destination:=Range(Cells(d, 1), Cells(d, 1)))
.Name = _
FI
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlInsertDeleteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
If d > 1 Then
Rows(d & ":" & d + 1).Select
Selection.Delete Shift:=xlUp
Else
Rows(d & ":" & d).Select
Selection.Delete Shift:=xlUp
End If
Windows("BITlyGoogleMapChartsBLOG.xls").Activate
c = c + 1
Sheets("URLs").Select
Wend
Sheets("DATA").Select
Rows("1:1").Select
Selection.Replace What:="/data/countries/", Replacement:="", LookAt:= _
xlPart, SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="/data/", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="/", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
Selection.Replace What:="_", Replacement:="", LookAt:=xlPart, _
SearchOrder:=xlByRows, MatchCase:=False, SearchFormat:=False, _
ReplaceFormat:=False
'Range(ActiveCell.Row & ":" & ActiveCell.Row).Select
End Sub
