Thursday, September 29, 2011

Mapping bit.ly links using Excel macros and Google map charts

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  

2 comments:

GMAC said...

Range("A1").End(xlDown).Offset(1, 0).Select

Wont allow??

Robert Russell said...

Hi,
Not sure what you mean by won't allow...
Can you explain in more detail.
Regards,
Robert

Post a Comment

Google +