[ 2012 @ 14.09.2015. 07:33 ] @
Imam jedan macro za kopiranje podataka sa web sajta www.xscores.com, pokupio sam ga pre vise godina, radio je kako treba, prestao sam da ga koristim pre dve-tri godine i to je bilo snimljeno na nekom HDD. Juce sam trazeci nesto slicno i naleteo na ovaj macro, ali sad nece da radi. Evo vec nekoliko sati se zafrkavam ali nikako da povucem podatke. Da li bi neko imao ideju gde moze biti problem?

Code:
Sub xScoresTable_Import()

Dim ie As InternetExplorer
Dim i As Range
Dim x As Range
Dim y As Range
Dim BinString As String
 
Set ie = CreateObject("InternetExplorer.Application")
ie.Visible = True
'Go to this Web Page!
ie.navigate "http://www.xscores.com/LiveSco...amp;newState=promptSoccerTable "
'Check for good connection to web page loop!
Do Until ie.readyState = READYSTATE_COMPLETE
DoEvents
Loop
Do Until ie.Busy = False
DoEvents
Loop
' type STOP in cell A1 to stop the macro/refresh
1
If Range("A1").Value = "STOP" Then Exit Sub
Cells.Select
Selection.Clear '.Delete
Range("A1").Select
Dim oResultPage As HTMLDocument
Dim AllTables As IHTMLElementCollection
Dim xTable As HTMLTable
Dim TblRow As HTMLTableRow
Dim myWkbk As Worksheet
 
'copy "data" table
Set oResultPage = ie.Document
Set AllTables = oResultPage.getElementsByTagName("table")
Set xTable = AllTables.Item(2)
Set myWkbk = ActiveWorkbook.Sheets("Sheet2")
For Each TblRow In xTable.Rows
    r = r + 1
    For Each tblCell In TblRow.Cells
        c = c + 1
        myWkbk.Cells(r, c) = tblCell.innerText
    Next tblCell
    c = 0
Next TblRow
r = 0
' refresh values every 15 mins
s = Now
Do Until Now >= s + TimeValue("00:15:00")
DoEvents
Loop
GoTo 1
End Sub


Macro sam preuzeo sa ove lokacije: http://www.mrexcel.com/forum/e...7-copy-webdata-into-excel.html

[ timmy @ 16.09.2015. 07:30 ] @
Promenila se struktura stranice, ugnezdili su jos tabela tako da je potrebno promeniti redni broj tabele koja se importuje. Dakle, treba promeniti red

Code:
Set xTable = AllTables.Item(2)


u

Code:
Set xTable = AllTables.Item(4)


Pozdrav
[ 2012 @ 16.09.2015. 08:45 ] @
Hvala. Probacu kasnije da li radi, ali verujem da si proverio.

Imam jos jedno pitanje u vezi ovoga, ali ne mogu ti postaviti pitanje sa ove igracke.
[ 2012 @ 16.09.2015. 09:22 ] @
@timmy

Izvrsio sam korekciju prema tvom uputstvu i sad mi javlja sledecu gresku:

[ 2012 @ 16.09.2015. 14:44 ] @
nasao sam jos jednu verziju, ali ni ona ne radi kdo mene. Moze da pokusate pa da mi kazete da li radi kod vas.

Code:
Sub xscores()
Application.ScreenUpdating = False
Dim strURL As String
Dim ieDoc As Object
Dim AllTables As Object
Dim xTable As Object
Dim myWkSht As Worksheet
Dim TblRow As Object
Dim tblCell As Object

Dim r As Integer
Dim c As Integer
Columns("N:O").NumberFormat = "@"
strURL = "http://xscores.com/LiveScore.do?state=soccer&sport=1"

If t = CDate(0) Then
Call NavigateTo(strURL)
End If

Set ieDoc = IE.Document
Set AllTables = ieDoc.frames(3).Document.frames(1).Document.getElementsByTagName("TABLE")
Set xTable = AllTables.Item(0)
Set myWkSht = ThisWorkbook.Sheets("Sheet1")

r = 0
c = 0

For Each TblRow In xTable.Rows
r = r + 1
For Each tblCell In TblRow.Cells
c = c + 1
myWkSht.Cells(r, c) = tblCell.innerText
Next tblCell
c = 0
Next TblRow
r = 0

Dim rng As Range
For Each rng In Range(Sheets(1).Range("A1"), Sheets(1).Range("A65536").End(xlUp))

If rng.Text = "K/O" Then
rng.Offset(0, 3).Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
rng.Offset(0, 8).Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
rng.Offset(0, 16).Select
Selection.Insert Shift:=xlToRight, CopyOrigin:=xlFormatFromLeftOrAbove
End If
Next rng
Columns("U:U").ClearContents
Range("A1").Select

'Call DisconnectFrom
't is set at 1 minute intervals
t = Now() + TimeValue("00:01:00")
Application.OnTime EarliestTime:=t, Procedure:="xscores", Schedule:=True
Application.ScreenUpdating = True
End Sub