Navigacija
Lista poslednjih: 16, 32, 64, 128 poruka.

Kopiranje sadrzaja sa web sajta u excel dokument

[es] :: Office :: Excel :: Kopiranje sadrzaja sa web sajta u excel dokument

[ Pregleda: 1847 | Odgovora: 4 ] > FB > Twit

Postavi temu Odgovori

Autor

Pretraga teme: Traži
Markiranje Štampanje RSS

2012

Član broj: 296004
Poruke: 248



+926 Profil

icon Kopiranje sadrzaja sa web sajta u excel dokument14.09.2015. u 07:33 - pre 103 meseci
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

 
Odgovor na temu

timmy
Jovan Timotijevic

Moderator
Član broj: 37087
Poruke: 634

Sajt: www.e-tim.net


+89 Profil

icon Re: Kopiranje sadrzaja sa web sajta u excel dokument16.09.2015. u 07:30 - pre 103 meseci
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
 
Odgovor na temu

2012

Član broj: 296004
Poruke: 248



+926 Profil

icon Re: Kopiranje sadrzaja sa web sajta u excel dokument16.09.2015. u 08:45 - pre 103 meseci
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.
 
Odgovor na temu

2012

Član broj: 296004
Poruke: 248



+926 Profil

icon Re: Kopiranje sadrzaja sa web sajta u excel dokument16.09.2015. u 09:22 - pre 103 meseci
@timmy

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

Prikačeni fajlovi
 
Odgovor na temu

2012

Član broj: 296004
Poruke: 248



+926 Profil

icon Re: Kopiranje sadrzaja sa web sajta u excel dokument16.09.2015. u 14:44 - pre 103 meseci
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
 
Odgovor na temu

[es] :: Office :: Excel :: Kopiranje sadrzaja sa web sajta u excel dokument

[ Pregleda: 1847 | Odgovora: 4 ] > FB > Twit

Postavi temu Odgovori

Navigacija
Lista poslednjih: 16, 32, 64, 128 poruka.