Refaz
Destek Ekibi
- Katılım
- 11 Ağu 2021
- Mesajlar
- 5,155
- Çözümler
- 653
- Aldığı beğeni
- 5,010
- Excel V
- Office 2024 TR
Merhaba.
Acemi olarak bir siteden maç puan durumu tablosu çektim ve kod çalışıyor.
Yaptığım kodda A3 e geliyor sonra B3 e sonrasında A4 ve B4 diye taki 20.satıra kadar veriler aktarılıyor.
En sondada C ileJ aralığına veri geliyor.
Sorum ise kod çalışırken önce satır no ikinci olarak klüp adı ve sonrasında C den J sütununa kadar ilgili verilen sırayla gelmesi gerekiyor.
Yani 3.satıra A3e geldi,B3 e klüp ad,C3 ten J3 e kadar ilgili verilerin gelip alt satırdan aynen devam etmesi gerekiyor.
Kodu adım adım çalıştırınca anlatmak istediğim anlaşılır bence.
Sitede tesadüf bulundu puan tablosu site aranırken şansımada hep böyle garip html kodlu siteler çıkıyor
Birde başkalarına lazım olursa diye konu açtım örnek olarak.
Kodda altta.
Acemi olarak bir siteden maç puan durumu tablosu çektim ve kod çalışıyor.
Yaptığım kodda A3 e geliyor sonra B3 e sonrasında A4 ve B4 diye taki 20.satıra kadar veriler aktarılıyor.
En sondada C ileJ aralığına veri geliyor.
Sorum ise kod çalışırken önce satır no ikinci olarak klüp adı ve sonrasında C den J sütununa kadar ilgili verilen sırayla gelmesi gerekiyor.
Yani 3.satıra A3e geldi,B3 e klüp ad,C3 ten J3 e kadar ilgili verilerin gelip alt satırdan aynen devam etmesi gerekiyor.
Kodu adım adım çalıştırınca anlatmak istediğim anlaşılır bence.
Sitede tesadüf bulundu puan tablosu site aranırken şansımada hep böyle garip html kodlu siteler çıkıyor
Birde başkalarına lazım olursa diye konu açtım örnek olarak.
Kodda altta.
Rich (BB code):
Sub TAbloAL1Dz()
Dim html As Object, syf As Worksheet
Dim satir As Long, sutun As Byte, x As Byte
' Application.ScreenUpdating = False
Set syf = ThisWorkbook.Worksheets("Sayfa1")
syf.UsedRange.ClearContents
On Error GoTo hata
Set html = CreateObject("htmlfile")
With CreateObject("MSXML2.XMLHTTP")
.Open "GET", "https://www.hurriyet.com.tr/sporarena/puan-durumu/", False
.send
html.body.innerHTML = .responseText
End With
syf.UsedRange.Cells.ClearContents
satir = 2
sutun = 2
'----------------------------------------Basliklar icin-----------------------------------------------------------------------
syf.Cells(1, 1).Value = html.getElementsByClassName("pointtable-action-wrapper ")(0).getElementsByTagName("h1")(0).innerText
For Each tr In html.getElementsByClassName("pointtable-header")
For Each td In tr.getElementsByClassName("header-main")
For Each td2 In tr.getElementsByClassName("header-detail")
syf.Cells(satir, sutun).Value = td.innerText & td2.innerText
Next
Next
For Each td In tr.getElementsByClassName("pointtable-header-center")
For Each td2 In td.getElementsByClassName("pointtable-small-item")
sutun = sutun + 1
syf.Cells(satir, sutun).Value = td2.innerText
Next
Next
Next
'------------------------------------------------------------------------------------------------------
'Satir ve sütunlar tablo
satir = 3
sutun = 1
For Each tr In html.getElementsByClassName("pointtable-content")
For Each td In tr.getElementsByClassName("pointtable-content-left")
For Each td1 In td.getElementsByClassName("pointtable-team-number")
syf.Cells(satir, sutun).Value = td1.innerText
For Each td2 In td.getElementsByTagName("h3")
syf.Cells(satir, sutun + 1).Value = td2.innerText
Next
Next
satir = satir + 1
sutun = 1
Next
satir = 3
sutun = 3
For Each td3 In tr.getElementsByClassName("pointtable-content-center")
For Each td4 In td3.getElementsByClassName("pointtable-small-item")
syf.Cells(satir, sutun).Value = td4.innerText
sutun = sutun + 1
Next
satir = satir + 1
sutun = 3
Next
Next
GoTo sonsub
hata:
MsgBox "Hata olustu", vbCritical, "Hata"
sonsub:
Set syf = Nothing: Set html = Nothing: Set tr = Nothing: Set td = Nothing
' Application.ScreenUpdating = True
End Sub
