Soru Dizi takvimi bilgilerini çekme makrosu

[Haluk]

Anlaşıldı ...... bir şekilde, bilgisayarınızdaki "XMLHTTP" nesnesi "NextSibling" metodunu desteklemiyor.

Onun yerine başka birşey kullanmak gerekiyor.

.

 

[Zeki Gürsoy]

Emülator ayarlaması işe yarayabilir...

WebBrowser hatası

altı ay kadar önce eklediğim WebBrowser artık çalışmıyor. Hata Şöyle: Komut dizisi hatası Satır : 2 Karakter :29745 Hata:Nesne 'addEventListener' özelliğini veya yöntemini desteklemez. şeklinde defalarca tekrar denememe rağmen sürekli aynı hatayı veriyor. Bu konuda bilen arkadaşların...

www.excel.web.tr

.

 

[Haluk]

Office365 için bir de aşağıdaki kodu deneyin, olacak mı bilmem.... (2010 versiyonda bu da çalışıyor)

Sub Test4()
'   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
            j = j + 1
            Cells(1, j) = objCollection(i).innerText
        End If
        i = i + 1
    Loop
   
    Set objCollection = HTML.getElementsByTagName("ul")
    i = 0
    j = 1
   
    Do While i < objCollection.Length
        If objCollection(i).ClassName = "episodes" Then
            j = j + 1
            k = 2
            xData = Split(objCollection(i).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]

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

.

Haluk hocam en son verdiğin kodu çalıştırınca arada boşluklar var, onları kaldırabilir miyiz?

 

[Haluk]

Tuhaf.... bende 5 No'lu mesajdaki görselde belirttiğim gibi çıkıyor.


Siz bir de, kodda ilgili yeri aşağıdakiyle değiştirip deneyin;

            For z = LBound(xData) To UBound(xData)
                If Len(xData(z)) > 2 Then
                    Cells(k, j) = xData(z)
                    k = k + 1
                End If
            Next

.

 

[ibere]

Tuhaf.... bende 5 No'lu mesajdaki görselde belirttiğim gibi çıkıyor.


Siz bir de, kodda ilgili yeri aşağıdakiyle değiştirip deneyin;

            For z = LBound(xData) To UBound(xData)
                If Len(xData(z)) > 2 Then
                    Cells(k, j) = xData(z)
                    k = k + 1
                End If
            Next

.

Sub Test4()
'   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
            j = j + 1
            Cells(1, j) = objCollection(i).innerText
        End If
        i = i + 1
    Loop
 
    Set objCollection = HTML.getElementsByTagName("ul")
    i = 0
    j = 1
 
    Do While i < objCollection.Length
        If objCollection(i).ClassName = "episodes" Then
            j = j + 1
            k = 2
            xData = Split(objCollection(i).innerText, vbCrLf)
         
            For z = LBound(xData) To UBound(xData)
                If Len(xData(z)) > 2 Then
                    Cells(k, j) = xData(z)
                    k = k + 1
                End If
            Next
        End If
        i = i + 1
    Loop
 
    Set objShows = Nothing
    Set HTML = Nothing
    Set HTTP = Nothing
    ActiveSheet.UsedRange.EntireColumn.AutoFit
End Sub

10 numara oldu hocam, teşekkür ederim. Kullanmak isteyen olursa diye kodları buraya bıraktım.