VBA for Excel 2003

[Gandalf the Grey]

I am trying to import data from a URL. My code works for XML, but not for the data in this URL. I can copy and paste the data into a spreadsheet, but don't know how to make the code work. Some one please help a lost soul in the wilderness...

ActiveWorkbook.Xml doesn't work, what does?

URL of interest: Einstein@Home Team stats for XtremeSystems

Current code:

Public Sub CapTeamStats()

Dim lgRow As Long 'Row Index
Dim lgTRow As Long 'Row Index

Dim boSvWarn As Boolean 'Save Application Warning Value

Const coXTbl As String = "There are more active members than lastweek Members table allows" & _
vbNewLine & vbNewLine & "increase the size and rerun!"

'/*---------------------------------*/
'/* Declare Team Capture URL */
'/*---------------------------------*/
Const coTSURL As String = "http://stats.kwsn.net/team.php?proj=einstein&teamid=6105"

Worksheets("WCG").Activate 'Set Active Sheet

'/*---------------------*/
'/* Clear Capture Sheet */
'/*---------------------*/
Cells.Select 'Select Entire Sheet
Selection.ClearContents 'Clear Contents

Cells(1, 1).Select 'Select First Cell in Active Sheet

boSvWarn = Application.DisplayAlerts 'Save Warning Setting
Application.DisplayAlerts = False 'Suppress Warnings
ActiveWorkbook.XmlImport URL:=coTSURL, ImportMap:=Nothing, _
Overwrite:=True, Destination:=Range("$A$1") 'Import XML File
Application.DisplayAlerts = boSvWarn 'Restore Warning Setting

lgRow = 2 'Set Starting Row

Do While Cells(lgRow, 15).Value <> vbNullString
lgTRow = lgRow + 4

If Left(Sheets("thisweek").Cells(lgTRow, 2).Value, 11) = "Team Totals" Then
MsgBox coXTbl, vbOKOnly, "Error - Active Member Space" 'Notify User
Exit Sub
End If

Sheets("thisweek").Cells(lgTRow, 2).Value = Cells(lgRow, 4).Value 'Member Name
Sheets("thisweek").Cells(lgTRow, 4).Value = Cells(lgRow, 7).Value 'Total Credits
Sheets("thisweek").Cells(lgTRow, 7).Value = Cells(lgRow, 8).Value 'Average credits
lgRow = lgRow + 1
Loop

lgTRow = lgTRow + 1

Do
If Left(Sheets("thisweek").Cells(lgTRow, 2).Value, 11) = "Team Totals" Then
Exit Do
End If

Sheets("thisweek").Cells(lgTRow, 2).Value = vbNullString
Sheets("thisweek").Cells(lgTRow, 4).Value = vbNullString
Sheets("thisweek").Cells(lgTRow, 7).Value = vbNullString
lgTRow = lgTRow + 1
Loop

Worksheets("thisweek").Activate 'Set Active Sheet

End Sub
____________________________________________________________

Thanks for the assist,
Gandalf

 

[John_w]

Just run a web query:

Sub Macro1()
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://stats.kwsn.net/team.php?proj=einstein&teamid=6105", Destination:= _
        Range("A1"))
        .Name = "team.php?proj=einstein&teamid=6105"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "2"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
End Sub

 

[Gandalf the Grey]

Just run a web query:

Sub Macro1()
    With ActiveSheet.QueryTables.Add(Connection:= _
        "URL;http://stats.kwsn.net/team.php?proj=einstein&teamid=6105", Destination:= _
        Range("A1"))
        .Name = "team.php?proj=einstein&teamid=6105"
        .FieldNames = True
        .RowNumbers = False
        .FillAdjacentFormulas = False
        .PreserveFormatting = True
        .RefreshOnFileOpen = False
        .BackgroundQuery = True
        .RefreshStyle = xlInsertDeleteCells
        .SavePassword = False
        .SaveData = True
        .AdjustColumnWidth = True
        .RefreshPeriod = 0
        .WebSelectionType = xlSpecifiedTables
        .WebFormatting = xlWebFormattingNone
        .WebTables = "2"
        .WebPreFormattedTextToColumns = True
        .WebConsecutiveDelimitersAsOne = True
        .WebSingleBlockTextImport = False
        .WebDisableDateRecognition = False
        .WebDisableRedirections = False
        .Refresh BackgroundQuery:=False
    End With
End Sub

This initially looks great. Thank you. Only one problem.
The second time I run the macros, it doesn't replace the first run, but appends the "new" data to the existing data.
A1 data is now written in cell G1, etc. How do we fix that?

In theory, I'd run this Worksheet once a week to get the new data. I do not want the old data retained.
That issue is handled another way.

 

[rjwebgraphix]

This initially looks great. Thank you. Only one problem.
The second time I run the macros, it doesn't replace the first run, but appends the "new" data to the existing data.
A1 data is now written in cell G1, etc. How do we fix that?

This should work for you.

Sub Macro1()

Dim lc As Long
Dim lr As Long
Dim c1 As Range
Dim c2 As Range
Dim rng As Range
Dim IsRngBlank As Range

'clear sheet before importing
On Error Resume Next
Set IsRngBlank = Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious)
On Error GoTo 0
If Not IsRngBlank Is Nothing Then
    lc = IsRngBlank.Column
    lr = IsRngBlank.Row
    Set c1 = Cells(1, "A")
    Set c2 = Cells(lr, lc)
    Set rng = Range(c1, c2)
    rng.ClearContents
End If
'import from web
With ActiveSheet.QueryTables.Add(Connection:= _
    "URL;http://stats.kwsn.net/team.php?proj=einstein&teamid=6105", Destination:= _
    Range("A1"))
    .Name = "team.php?proj=einstein&teamid=6105"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .WebSelectionType = xlSpecifiedTables
    .WebFormatting = xlWebFormattingNone
    .WebTables = "2"
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False
End With

End Sub

 

[Gandalf the Grey]

No joy.

It cleared the old data, then quit.

I don't know if this is important, but I'm importing the data at B1 vice A1.
I have to save column A for other code.

 

[rjwebgraphix]

It does matter. I modified to start it at B1 and only clear from B1 to end of data. Column A will be left untouched. Not sure why it quit. It runs for me just fine. Without going to the website I can tell you that Vortac is the first name on the list and you are 31st in the list.

Sub Macro1()

Dim lc As Long
Dim lr As Long
Dim c1 As Range
Dim c2 As Range
Dim rng As Range
Dim IsRngBlank As Range

'clear sheet before importing
On Error Resume Next
Set IsRngBlank = Cells.Find("*", SearchOrder:=xlByColumns, LookIn:=xlValues, SearchDirection:=xlPrevious)
On Error GoTo 0
If Not IsRngBlank Is Nothing Then
    lc = IsRngBlank.Column
    lr = IsRngBlank.Row
    Set c1 = Cells(1, "B")
    Set c2 = Cells(lr, lc)
    Set rng = Range(c1, c2)
    rng.ClearContents
End If
'import from web
With ActiveSheet.QueryTables.Add(Connection:= _
    "URL;http://stats.kwsn.net/team.php?proj=einstein&teamid=6105", Destination:= _
    Range("B1"))
    .Name = "team.php?proj=einstein&teamid=6105"
    .FieldNames = True
    .RowNumbers = False
    .FillAdjacentFormulas = False
    .PreserveFormatting = True
    .RefreshOnFileOpen = False
    .BackgroundQuery = True
    .RefreshStyle = xlInsertDeleteCells
    .SavePassword = False
    .SaveData = True
    .AdjustColumnWidth = True
    .RefreshPeriod = 0
    .WebSelectionType = xlSpecifiedTables
    .WebFormatting = xlWebFormattingNone
    .WebTables = "2"
    .WebPreFormattedTextToColumns = True
    .WebConsecutiveDelimitersAsOne = True
    .WebSingleBlockTextImport = False
    .WebDisableDateRecognition = False
    .WebDisableRedirections = False
    .Refresh BackgroundQuery:=False
End With

End Sub

 

[Gandalf the Grey]

No change. I thought those were the modifications for starting at B1.
I'd have felt a little stupid, if I'd have been wrong on that score.

Does the fact that I'm using Excel 2003 have anything to do with this problem?

FYI - this is what is going into the A column...
=TRIM(SUBSTITUTE(B2,LEFT(B2,FIND(" ",B2)-1),""))
It leaves me with just the username and not the #) in the front of the column B cells.


P.S. -in the words of **** Clark, "I'm 31st with a bullet." <label for="rb_iconid_7">

</label>

 

[Gandalf the Grey]

P.S. -in the words of **** Clark, "I'm 31st with a bullet." <label for="rb_iconid_7">

</label>

That's kind of sad when the first name of a man like D i c k Clark is blanked out.

 

[rjwebgraphix]

Are you saying it does nothing at all? I'm running xl03 too, so that isn't it at all. It does take a minute to pull down the data. It doesn't pull the data one item at a time, but pulls all the data then BAM it populates everything all at once. The trim doesn't matter as far as pulling down the data, but the first two rows pulled in are not actually part of the data set. So if you have that in A1, then maybe a modification to John's way of pulling the data down is needed and I would divert back to John for that one.

I would probably additionally ask if when you run it and it clears the sheet, is the cursor still an hourglass? It is for me until the data is all pulled in. Not to mention that I'm on dialup, so it probably takes longer to pull it in for me than it would on a broadband acct.

Still, with the actual pulling down of the data, if it isn't how you need, I'd divert back to John for that one. I just thought I'd help with the clearing of data, but I really don't do much with web data.

 

[Gandalf the Grey]

Are you saying it does nothing at all? I'm running xl03 too, so that isn't it at all. It does take a minute to pull down the data. It doesn't pull the data one item at a time, but pulls all the data then BAM it populates everything all at once. The trim doesn't matter as far as pulling down the data, but the first two rows pulled in are not actually part of the data set. So if you have that in A1, then maybe a modification to John's way of pulling the data down is needed and I would divert back to John for that one.

I would probably additionally ask if when you run it and it clears the sheet, is the cursor still an hourglass? It is for me until the data is all pulled in. Not to mention that I'm on dialup, so it probably takes longer to pull it in for me than it would on a broadband acct.

Still, with the actual pulling down of the data, if it isn't how you need, I'd divert back to John for that one. I just thought I'd help with the clearing of data, but I really don't do much with web data.

1. I'm on Comcast Broadband/Cable. I'm not sure what they call it, but it's fast. <label for="rb_iconid_7">

</label>
2. The cursor is a cross sign not an hourglass. Column A is full of #VALUE!, because there is no data in column B.
3. Just in case, I waited, and waited, and waited, but nothing happened. I think the smiley even started to frown at me. <label for="rb_iconid_9">

</label>

I guess we'll just have to wait until John is able to come to my rescue. But, I do thank you for giving it a try. Don't be sad. Whenever I try to do something like this, something always comes up to make it difficult. You grow use to it, after a while. I remember how mad I got, when Noah built the silly boat. Until it started to rain. Do you know how hard it is to tread water for forty days and forty nights?

Good night rj.

Gandalf