View Single Post
  #5   Report Post  
Posted to microsoft.public.excel.programming
Jason Jason is offline
external usenet poster
 
Posts: 367
Default Loop through date range, but skip down to next year


I am pulling the data from the HTML source code off the website.
Here is my full code below to help. To replicate the problem I am seeing,
column A with Jan 2000 to say Dec 2004 incrementing by month

Jan 2000
Feb 2000
.....

Running the code will put the value for January total for 2000 in every
month with the year 2000, Janurary total for 2001 in every month for 2001 and
so on. We want to use a program (that works correctly) similar to the one
below, so we can add on later for other countries, etc.


Option Explicit

Sub getExportCanada()
Dim c As Range, rng As Range
Dim myStr As String
Dim test As Variant
Dim Val As Variant
Dim IE As Object

Const sURL1 As String = "http://tonto.eia.doe.gov/dnav/ng/hist/n9132cn2m.htm"
Dim sURLdate As String

Application.Cursor = xlWait
Set IE = CreateObject("InternetExplorer.Application")

IE.Navigate sURL1
While IE.ReadyState < 4
DoEvents
Wend
myStr = IE.Document.body.innerhtml

Dim StartRow As Long
Set rng = Range("A2").CurrentRegion
'look for last filled in row
Set c = rng.SpecialCells(xlCellTypeBlanks).Areas(1)
Set c = c.Resize(1, 1)

StartRow = c.Row - rng.Row

Set rng = rng.Offset(rowoffset:=StartRow).Resize( _
rowsize:=rng.Rows.Count - StartRow, columnsize:=1)

For Each c In rng
sURLdate = Format(c.Value2, "yyyy")
c.Offset(0, 1).Value = RegexMid(myStr, sURLdate, "class=b3")
Next c

IE.Quit
Set IE = Nothing
Application.Cursor = xlDefault
End Sub

Private Function RegexMid(s As String, sYear As String, sMonthTotal) As String
Dim re As Object, mc As Object
Set re = CreateObject("vbscript.regexp")
re.IgnoreCase = True
re.MultiLine = True
re.Global = True
re.Pattern = "\b" & "nbsp;" & sYear & "[\s\S]+?" & sMonthTotal & "\D+(\d+)"

' Yes I know the syntax for the line above is wrong, I am working on that as
well

If re.test(s) = True Then
Set mc = re.Execute(s)
RegexMid = mc(0).SubMatches(0)
End If
Set re = Nothing
End Function