Soru Dizi takvimi bilgilerini çekme makrosu

[ibere]

Arkadaşlar https://www.tvmaze.com/calendar web sitesinden bilgileri excele aktarmak istiyorum. Boş vakti olup ilgili dizileri excele çekecek makroyu yazıp paylaşabilir misiniz acaba ? teşekkürler

 

[Haluk]

Sub Test()
'   Haluk - 21/06/2022
'   sa4truss@gmail.com

    Dim HTTP As Object, HTML As Object, i As Integer, j As Integer, k As Integer, z As Integer
    Dim myURL As String
    
    Range("B1:AJ" & Rows.Count) = ""
    
    Set HTML = CreateObject("HTMLFILE")
    Set HTTP = CreateObject("MSXML2.XMLHTTP")
    
    myURL = "https://www.tvmaze.com/calendar"
    
    HTTP.Open "GET", myURL, False
    HTTP.send
    
    HTML.body.innerHTML = HTTP.responseText
    Set objCollection = HTML.getElementsByTagName("span")
    
    i = 0
    j = 1
    Do While i < objCollection.Length
        If objCollection(i).classname = "dayofmonth" Then
            Set objShows = objCollection(i).NextSibling
            j = j + 1
            k = 2
            
            Cells(1, j) = objCollection(i).innerText
            xData = Split(objShows.innerText, vbCrLf)
            
            For z = LBound(xData) To UBound(xData)
                Cells(k, j) = xData(z)
                k = k + 1
            Next
        End If
        i = i + 1
    Loop
    
    Set objShows = Nothing
    Set HTML = Nothing
    Set HTTP = Nothing
End Sub

.

 

[ibere]

Teşekkür ederim Haluk bey

 

[ibere]

Sub Test()
'   Haluk - 21/06/2022
'   sa4truss@gmail.com

    Dim HTTP As Object, HTML As Object, i As Integer, j As Integer, k As Integer, z As Integer
    Dim myURL As String
   
    Range("B1:AJ" & Rows.Count) = ""
   
    Set HTML = CreateObject("HTMLFILE")
    Set HTTP = CreateObject("MSXML2.XMLHTTP")
   
    myURL = "https://www.tvmaze.com/calendar"
   
    HTTP.Open "GET", myURL, False
    HTTP.send
   
    HTML.body.innerHTML = HTTP.responseText
    Set objCollection = HTML.getElementsByTagName("span")
   
    i = 0
    j = 1
    Do While i < objCollection.Length
        If objCollection(i).classname = "dayofmonth" Then
            Set objShows = objCollection(i).NextSibling
            j = j + 1
            k = 2
           
            Cells(1, j) = objCollection(i).innerText
            xData = Split(objShows.innerText, vbCrLf)
           
            For z = LBound(xData) To UBound(xData)
                Cells(k, j) = xData(z)
                k = k + 1
            Next
        End If
        i = i + 1
    Loop
   
    Set objShows = Nothing
    Set HTML = Nothing
    Set HTTP = Nothing
End Sub

.

Referanslardan neyi aktive etmem gerekiyor acaba ?

 

[Haluk]

Herhangibir referans eklemenize gerek yok.... kodu bir modül içine yerleştirip, çalıştırmanız yeterli. Eğer sizin kendi dosyanızda eksik bir referans varsa, onu kaldırıp kodu tekrar deneyin.




.

 

[ibere]

Herhangibir referans eklemenize gerek yok.... kodu bir modül içine yerleştirip, çalıştırmanız yeterli. Eğer sizin kendi dosyanızda eksik bir referans varsa, onu kaldırıp kodu tekrar deneyin.


Ekli dosyayı görüntüle 237375

.

Hata aldım Haluk bey, ilginizden ötürü çok teşekkür ederim

 

[Haluk]

Referansları kontrol ettiniz mi? "Missing-Eksik" olarak işaretlenmiş referans olabilir sizde ....




.

 

[ibere]

Referansları kontrol ettiniz mi? "Missing-Eksik" olarak işaretlenmiş referans olabilir sizde ....


Ekli dosyayı görüntüle 237378

.

Office 365 kullanıyorum Haluk hocam, office 14 yerine 16 seçili. Bu sebeple çalışmıyor olabilir mi ?

 

[Haluk]

Hayır.... sizdeki Office versiyonu olması gerekir, yani bir problem görünmüyor.

Sizde çalışmamasının nedeni ne olabilir, bilemedim....

.

 

[ibere]

Teşekkür ederim yinede hocam

 

[Haluk]

Son çare, bende çalışan dosyayı ekleyeyim .... Bir de böyle deneyin.


.

 

[Necdet]

Merhaba Haluk bey,
bende de 365 var arkadaşımızın hatalarını ben de aldım. Dosyada da sonuç değişmedi.

 

[Haluk]

Bence, benim 2010 versiyonu gibi daha iyi bir versiyon kullanmaniz iyi olur

.

 

[Necdet]

Bence, benim 2010 versiyonu gibi daha iyi bir versiyon kullanmaniz iyi olur

.

Ne de olsa eski iyidir

 

[ibere]

Bence, benim 2010 versiyonu gibi daha iyi bir versiyon kullanmaniz iyi olur

.

Teşekkürler hocam, office 2010 yükleyeyim

 

[Haluk]

Office365'deki sorun "Split" fonksiyonundan mı yoksa başka bir şeyden mi kaynaklanıyor, teşhis edebilmek için aşağıdaki basit kodu çalıştırırsanız anlayabiliriz.

Sub Test()
    MsgBox Split("Bu bir test metnidir")(2)
End Sub

.

 

[ibere]

Office365'deki sorun "Split" fonksiyonundan mı yoksa başka bir şeyden mi kaynaklanıyor, teşhis edebilmek için aşağıdaki basit kodu çalıştırırsanız anlayabiliriz.

Sub Test()
    MsgBox Split("Bu bir test metnidir")(2)
End Sub

.

Bu kod çalıştı hocam

 

[Haluk]

Hmmm..... o zaman sıkıntı daha derinlerde.

.

 

[Haluk]

Peki, o zaman aşağıdaki kod hangi satırda ne hatası veriyor Office365'de?

Sub Test3()
'   Haluk - 21/06/2022
'   sa4truss@gmail.com

    Dim HTTP As Object, HTML As Object, i As Integer
    
    Range("B1:AJ" & Rows.Count) = ""
    
    Set HTML = CreateObject("HTMLFILE")
    Set HTTP = CreateObject("MSXML2.XMLHTTP")
    
    myURL = "https://www.tvmaze.com/calendar"
    
    HTTP.Open "GET", myURL, False
    HTTP.send
    
    HTML.body.innerHTML = HTTP.responseText
    Set objCollection = HTML.getElementsByTagName("span")
    
    i = 0
    Do While i < objCollection.Length
        If objCollection(i).ClassName = "dayofmonth" Then
            Set objShows = objCollection(i)
            MsgBox objShows.innerText
            MsgBox objShows.NextSibling.innerText
        End If
        i = i + 1
    Loop
    
    Set objShows = Nothing
    Set HTML = Nothing
    Set HTTP = Nothing
End Sub

.

 

[ibere]

Peki, o zaman aşağıdaki kod hangi satırda ne hatası veriyor Office365'de?

Sub Test3()
'   Haluk - 21/06/2022
'   sa4truss@gmail.com

    Dim HTTP As Object, HTML As Object, i As Integer
   
    Range("B1:AJ" & Rows.Count) = ""
   
    Set HTML = CreateObject("HTMLFILE")
    Set HTTP = CreateObject("MSXML2.XMLHTTP")
   
    myURL = "https://www.tvmaze.com/calendar"
   
    HTTP.Open "GET", myURL, False
    HTTP.send
   
    HTML.body.innerHTML = HTTP.responseText
    Set objCollection = HTML.getElementsByTagName("span")
   
    i = 0
    Do While i < objCollection.Length
        If objCollection(i).ClassName = "dayofmonth" Then
            Set objShows = objCollection(i)
            MsgBox objShows.innerText
            MsgBox objShows.NextSibling.innerText
        End If
        i = i + 1
    Loop
   
    Set objShows = Nothing
    Set HTML = Nothing
    Set HTTP = Nothing
End Sub

.

Sarı kısımda hocam