call getYearZoneRanks(2007)
This will generate the monthly worksheets for the complete year 2007.
Option Explicit
Sub getZoneRanks()
If Not WhoAmIFilled Then Exit Sub
Dim ws As Worksheet
Set ws = Worksheets("Overall")
ws.Activate
SetCalc False
GetWebData ws.Cells(2, 1), [maxZones].Value
SetCalc True
End Sub
Sub getThisMonthZR()
If Not WhoAmIFilled() Then Exit Sub
SetCalc False
getMonthZoneRanks month(Now()), year(Now())
[OneYear].Offset(DateDiff("m", [OneYear].Range("A1").Value, Now()) - 12, 0).Name = "OneYear"
SetCalc True
End Sub
Sub getThisMonth()
If Not WhoAmIFilled() Then Exit Sub
Dim ws As Worksheet, r As Long
Set ws = Worksheets("Month")
SetCalc False
With ws
.Activate
GetWebData .Cells(2, 1), [maxMonthZones].Value, month(Now()), year(Now())
For r = 3 To [maxMonthZones].Value * 1.1
With .Cells(r, 4)
If .Value <> "Points" Then .NumberFormatLocal = "# ### ###"
End With
Next
.Cells(1, 2).Value = month(Now()) & " " & year(Now())
End With
SetCalc True
End Sub
Sub Formula2Value()
Dim c As Range
SetCalc False
ActiveSheet.EnableCalculation = False
For Each c In Selection
c.Formula = c.Value
Next c
SetCalc True
End Sub
Sub getYearZoneRanks(year As Integer)
If Not WhoAmIFilled() Then Exit Sub
Dim month As Integer
SetCalc False
For month = 12 To 1 Step -1
Call getMonthZoneRanks(month, year)
Next
SetCalc True
End Sub
Sub getMonthZoneRanks(month As Integer, year As Integer)
If Not WhoAmIFilled() Then Exit Sub
Dim ws As Worksheet, r As Long
On Error Resume Next
Set ws = Worksheets(year & " " & month)
On Error GoTo 0
If ws Is Nothing Then
Call Worksheets("Month").Copy(After:=Worksheets("Ranking"))
Set ws = Worksheets("Month (2)")
ws.Name = year & " " & month
ws.Tab.Color = RGB(255, 0, 0)
ws.Cells(1, 2).Value = year & " " & month
ws.Range(Cells(3, 1), Cells(300, 4)).Delete
End If
With ws
.Activate
GetWebData .Cells(2, 1), [maxMonthZones].Value, month, year
For r = 3 To [maxMonthZones].Value * 1.1
With .Cells(r, 4)
If .Value <> "Points" Then .NumberFormatLocal = "# ### ###"
End With
Next
End With
End Sub
Sub GetWebData(rng As Range, zones As Long, Optional month As Integer = 0, Optional year As Integer)
Dim URL As String
URL = "http://www.experts-exchange.com/experts.jsp?etIndex=3&expertName=" & [WhoAmI].Value
If month <> 0 Then URL = URL & "&filterMonth=" & month & "&filterYear=" & year
With Application
.DecimalSeparator = "."
.ThousandsSeparator = "ยท"
.UseSystemSeparators = False
End With
Dim i As Long
For i = 1 To zones Step 10
With rng.Parent.QueryTables.Add(Connection:="URL;" & URL & "&zrStart=" & i, Destination:=rng.Cells(1.1 * i, 1))
.Name = "experts.jsp?etIndex=3&expertName=" & [WhoAmI].Value
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = False
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = False
.RefreshPeriod = 0
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebTables = "11"
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh
End With
If i > 1 Then
If rng.Cells(i * 1.1 + 1, 2).Value = rng.Cells(i * 1.1 - 1, 2).Value Then
rng.Range(Cells(i * 1.1 + 1, 1), Cells(i * 1.1 + 1, 4)).Value = ""
Exit For
End If
End If
If rng.Cells((i + 10 - 1) * 1.1, 1).Value = "" Then Exit For
Next
For i = zones * 1.1 To 2 Step -1
With rng.Cells(i, 3)
If .Value = "No Certificates" Then .Value = " "
If .Value = "Level" Then
If i > 2 Then
rng.Rows(i).Hidden = True
End If
rng.Cells(i, 4) = ""
Else
' This is for all those countries where a comma is not a thousands separator ...
rng.Cells(i, 4).Value = Replace(rng.Cells(i, 4).Value, ",", "")
End If
End With
Next
Dim qt As QueryTable
For Each qt In ActiveSheet.QueryTables
qt.Delete
Next qt
Application.UseSystemSeparators = True
End Sub
Sub SetCalc(calc As Boolean)
Dim ws As Worksheet
For Each ws In Worksheets
ws.EnableCalculation = calc
Next ws
End Sub
Function WhoAmIFilled() As Boolean
Dim ws As Worksheet
With [WhoAmI]
If .Value = "" Then
Worksheets("RankDef").Activate
.Activate
.Interior.Color = RGB(255, 0, 0)
.Offset(, 1).Value = "<--- Please enter your EE Member name!"
Else
.Interior.Color = .Offset(1, 0).Interior.Color
.Offset(, 1).Clear
End If
End With
WhoAmIFilled = [WhoAmI].Value <> ""
End Function
Sub getMemberRanking()
If Not WhoAmIFilled() Then Exit Sub
Dim URL As String
Dim qt As QueryTable
URL = "http://www.experts-exchange.com/experts.jsp?etIndex=4&expertName=" & [WhoAmI].Value
On Error Resume Next
If [ScratchArea].Name = "" Then [RankDef!L1].Name = "ScratchArea"
On Error GoTo 0
[ScratchArea].Parent.Activate
Set qt = [ScratchArea].Parent.QueryTables.Add(Connection:="URL;" & URL & "&periodID=0", Destination:=[ScratchArea])
With qt
.WebTables = "11"
.FillAdjacentFormulas = False
.PreserveFormatting = True
.AdjustColumnWidth = False
.WebSelectionType = xlSpecifiedTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.SaveData = False
.BackgroundQuery = False
.RefreshStyle = xlOverwriteCells
.Refresh
End With
If [ScratchArea].Count = 1 Then Range([ScratchArea], [ScratchArea].Offset(10, 4)).Name = "ScratchArea"
' Some preparation for further processing
With [ScratchArea]
.Offset(0, 1).Name = "Lookup"
' Copy rank to the end, else we cannot use VLookup
.Range("E1:E11").Formula = "=" & [ScratchArea].Columns(1).Address
' Filter Expert in result rows
.Range("A13:A15").Formula = "= VLOOKUP(WhoAmI, Lookup, 4, FALSE)"
.Range("B13:B15").Formula = "= VLOOKUP(WhoAmI, Lookup, 1, FALSE)"
.Range("C13:C15").Formula = "= VLOOKUP(WhoAmI, Lookup, 2, FALSE)"
.Range("D13:D15").Formula = "= VLOOKUP(WhoAmI, Lookup, 3, FALSE)"
.Range("E13").Value = "Overall"
.Range("E14").Value = "Yearly"
.Range("E15").Value = "Monthly"
End With
' Now retrieve Overall, Year, Month
[ScratchArea].Range("A13:E13").Select
qt.Refresh
Call Formula2Value
[ScratchArea].Range("A14:E14").Select
qt.Connection = "URL;" & URL & "&periodID=1"
qt.Refresh
Call Formula2Value
[ScratchArea].Range("A15:E15").Select
qt.Connection = "URL;" & URL & "&periodID=2"
qt.Refresh
Call Formula2Value
' Now tricky bit - get last rank by using very high starting rank
URL = "http://www.experts-exchange.com/experts.jsp?etIndex=4"
With [ScratchArea].Range("F13")
.Select
qt.Connection = "URL;" & URL & "&periodID=0&hofStart=1000000"
qt.Refresh
.Value = [ScratchArea].Range("A2")
End With
With [ScratchArea].Range("F14")
.Select
qt.Connection = "URL;" & URL & "&periodID=1&hofStart=1000000"
qt.Refresh
.Value = [ScratchArea].Range("A2")
End With
With [ScratchArea].Range("F15")
.Select
qt.Connection = "URL;" & URL & "&periodID=2&hofStart=1000000"
qt.Refresh
.Value = [ScratchArea].Range("A2")
End With
' Cleanup
[Lookup].Name.Delete
[ScratchArea].ClearContents
qt.Delete
' Now we enter this into the Ranking worksheet
With [Ranking!A5].Offset(DateDiff("m", [Ranking!A5], Now))
.Range("B1").Value = Replace([ScratchArea].Range("D15").Value, ",", "")
.Range("C1").Value = [ScratchArea].Range("A15").Value
.Range("D1").Value = Replace([ScratchArea].Range("F15").Value, ",", "")
.Range("I1").Value = Replace([ScratchArea].Range("D14").Value, ",", "")
.Range("J1").Value = [ScratchArea].Range("A14").Value
.Range("K1").Value = Replace([ScratchArea].Range("F14").Value, ",", "")
.Range("M1") = Replace([ScratchArea].Range("D13").Value, ",", "")
.Range("N1") = [ScratchArea].Range("A13").Value
.Range("O1") = Replace([ScratchArea].Range("F13").Value, ",", "")
End With
End Sub
Sub getThisMonthZR()
getMonthZoneRanks month(Now()-5), year(Now()-5)
End Sub
that will allow for 5 days, so if you call it at 4th of November, it still retrieves October statistics.
Have a question about something in this article? You can receive help directly from the article author. Sign up for a free trial to get started.
Comments (88)
Author
Commented:Commented:
And then a later version to handle getting the history back.
Thanks !
Author
Commented:Yes, I think I should do so. I will (probably) create another article for that, because this one is already confusing enough. Scheduled for the weekend.
Author
Commented:Author
Commented:View More