Sub download_watch_list()
With Application
.Calculation = xlCalculationManual
.ScreenUpdating = False
Application.DisplayAlerts = False
'----------------------------------
'Delete old downloads
For Each ws In Worksheets
Select Case ws.Name
Case "Main", "vlookup", "Threads"
' do nothing
Case Else
ws.Delete
End Select
Next ws
'----------------------------------
'************* YOUR CODE IS HERE *************************
'Start downloads
Dim i As Long, url As String, sh As Worksheet, QName
With Sheets("Main")
For i = 7 To .Cells(65536, 1).End(xlUp).Row
If .Cells(i, 9).Value = "yes" Then
strFrmFullUrl = .Cells(i, 2).Value
End If
strFrmFullUrl = .Cells(i, 2).Value
'-------------------------------------------------------------------------------------------
'Sort out URL
'strExtractThreadNumber returns the position of "UTN="
intPositionofUTN = InStr(strFrmFullUrl, "UTN=")
strThreadNumber = Mid(strFrmFullUrl, intPositionofUTN + 4, 5) 'NB when thread numbers exceed 99999 then the number should be changed to 6!!
'create complete URL string
strUrlStem = "http://www.runnersworld.co.uk/forum/forummessages.asp?UTN="
strUrlMid = "&URN=12&dt=4&srchdte=0&cp=" ' the bit in the middle!
strUrlSuffix = "&v=6&sp="
'-------------------------------------------------------------------------------------------
'sort out pages to download
Set wsList = Worksheets.Add
intPageStart = .Cells(i, 7).Value
intPageFinish = .Cells(i, 8).Value
For intCnt = intPageStart To intPageFinish
Set wsDownload = Worksheets.Add
url = "Url;" & strUrlStem & strThreadNumber & strUrlMid & intCnt & strUrlSuffix
With wsDownload.QueryTables.Add(Connection:=url, Destination:=Range("A1"))
.WebSelectionType = xlEntirePage
.Refresh BackgroundQuery:=False
' If intCnt > 0 Then
'
' Else
'
' End If
End With
'-------------------------------------------------------------------------------------------
'this next line detects if the end of the thread has been reached
'-------------------------------------------------------------------------------------------
wsDownload.Range("a1:z1000").UnMerge
Set rngFind = wsDownload.Range("a1:z10000").Find("E-mail member", LookAt:=xlPart)
If wsDownload.Range("E12") = "Sorry this thread has been deleted, to access the parent section click here" Then GoTo ThreadEndReached
On Error GoTo ThreadEndReached
'Application.StatusBar = "Extracting posts from download ... "
wsDownload.Range(rngFind.Offset(0, -1).Address, rngFind.Offset(1000, 5).Address).Select
On Error GoTo ThreadEndReached
Call Edit_Links ' this macro splits hyperlinks into text and link.
wsDownload.Range(rngFind.Offset(0, -1).Address, rngFind.Offset(1000, 5).Address).Copy
Set rngLast = wsList.Range("b60000").End(xlUp)
Set rngPaste = rngLast.Offset(1, 0)
rngPaste.PasteSpecial xlPasteValues
ThreadEndReached:
wsDownload.Delete
'-------------------------------------------------------------------------------------------
Next
Set rngLast = wsList.Range("b60000").End(xlUp)
wsList.Range("a1") = 1
wsList.Range("a2") = 2
wsList.Range("a1:a2").AutoFill wsList.Range("a1:a" & rngLast.Row)
wsList.Range("a1:i" & rngLast.Row).Sort key1:=wsList.Range("b1")
Set rngLast = wsList.Range("b60000").End(xlUp)
wsList.Range("a10000:a" & rngLast.Row + 1).EntireRow.Delete
wsList.Range("a1:i" & rngLast.Row).Sort key1:=wsList.Range("a1")
Set rngPost = wsList.Range("g1")
intPostCnt = intPageStart * 20 - 19
'MsgBox "this is the value of intcnt " & intPgeCnt
intPgeCnt = intPageStart
txtPstNbr = "Post number " & intPostCnt & " page " & intPgeCnt 'to ensure the first postnumber is shown
counting = 1
'-------------------------------------------------------------------------------------------
Do Until rngPost.Row > 60000
rngPost.Offset(0, -2) = txtPstNbr
counting = counting + 1
intPostCnt = intPostCnt + 1
If counting > 20 Then
counting = 1
intPgeCnt = intPgeCnt + 1
Else
End If
txtPstNbr = "Post number " & intPostCnt & " page " & intPgeCnt
Set rngPost = rngPost.End(xlDown)
Loop
'-------------------------------------------------------------------------------------------
wsList.Range("a1").EntireColumn.Delete
wsList.Range("b1").EntireColumn.Delete
wsList.Range("a1").Select
wsList.Range("a1").EntireRow.Insert
wsList.Range("a1").EntireRow.Insert
wsList.Range("a1").Select
'-------------------------------------------------------------------------------------------
'-------------------------------------------------------------------------------------------
'calling various macros
Call formatting 'formatting the final text
Call clearcontents 'calls the macro clearcontents to clear the cells with print message in them.
Call TurnPosterlinkToPostername 'converts the poster's name shown as link back to just the name of the poster.
Call CountWords ' ensures only 25 words per line
'-------------------------------------------------------------------------------------------
Range("A5").Select
Selection.End(xlDown).Select
'-------------------------------------------------------------
'Name sheet
QName = .Cells(i, 1)
QName = Mid(QName, 1, 8)
QName = Replace(QName, ":", " ")
QName = Replace(QName, "\", " ")
QName = Replace(QName, "/", " ")
QName = Replace(QName, "?", " ")
QName = Replace(QName, "[", "(")
QName = Replace(QName, "]", ")")
QName = QName & " ..."
wsList.Name = QName
Do
If Err <> 0 Then
Err = 0
i = i + 1
sh.Name = QName & i 'if threadname already exists then 1,2,3 etc is added to the end
End If
Loop While Err <> 0
On Error GoTo 0
ActiveSheet.Move After:=Sheets("Threads")
'-------------------------------------------------------------
intCnt = intCnt + 1
Next
End With
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
Application.DisplayAlerts = True
End Sub