• Foruma hoş geldin 👋 Ziyaretçi

    Forum içeriğine ve tüm hizmetlerimize erişim sağlamak için foruma kayıt olmalı ya da giriş yapmalısınız. Foruma üye olmak tamamen ücretsizdir.

    Giriş yap veya Şimdi kayıt ol

Çözüldü internetten veri çekme (Span) harici

Bu konu çözüldü olarak işaretlenmiştir. Çözülmediğini düşünüyorsanız konuyu rapor edebilirsiniz.
Durum
Konu Çözümlendiği İçin Kapatılmıştır.
Refaz

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.
İnternetten veri çekme işine merak saldım bayağıda çözdüm ama bir yerde takıldım şimdilik.

ilk resimde kırmızıyla işaretlediğim yerdeki sadece saatlar gelecek.
En alttaki resimde span yazan yer gelmeyecek.
Kısaca sadece saatler nasıl getirilir?
Bu arada dosyadaki internet adreside sadece tesadüf veri çekmek için buldum tablo var diye.

Uzun yoldan alttaki kodla yaptım ama ben sadece meraktan sormak istedim.

Rich (BB code): 
Dim kelime, parca, birlestir

For i = 3 To syf.Cells(Rows.Count, 1).End(3).Row
    For k = 2 To 10
        kelime = syf.Cells(i, k).Value
        For j = 1 To Len(kelime)
            parca = Mid(kelime, j, 1)
            If IsNumeric(parca) = True Or parca = ":" Then birlestir = birlestir & parca
        Next
        syf.Cells(i, k).Value = birlestir
        birlestir = ""
    Next
Next



1.png
2.png
 

Ekli dosyalar

Çözüm
halily
aşağıdaki gibi dener misiniz hocam?
Kod: 
    For Each tr In html.getElementById("gungun").getElementsByTagName("ul")
        For Each td In tr.getElementsByTagName("li")
        tmp = td.innerText
            For Each Spn In td.getElementsByTagName("span")
                tmp = Spn.NextSibling.Data
            Next Spn

            syf.Cells(satir, sutun).Value = tmp
            sutun = sutun + 1
        Next
        satir = satir + 1
        sutun = 1
    Next
Tarihe göre sırala Oylara göre sırala
muratboz06' Alıntı:
syf.Cells(satir, sutun).Value = td.innerText satırını
syf.Cells(satir, sutun).Value = Right(td.innerText, 5) ile değiştirsek?
Genişletmek için tıkla...
Bu örnek için olur ama başka siteden saat harici almaya kalksak iş karışır bence.
Bende bir sürü kod yazmıştım sağdan kodu aklıma gelmedi :)
Yada geldi 4:05 yada diğeri 05:15 gibi olursa diye düşünüp vazgeçmitim galiba Right için.
 
Olumlu oy 0 Negatif oyla
Aslında alttaki gibi split ilede çözülüyor ama nedense kodu arka arkaya çalıştırınca hata veriyor bazen.
Benim asıl öğrenmek istediğim span kısmı mesela getElementsByTagName("span") bunun gibi birşeyler eklenip span varsa altındaki veri al gibi :)
Tamda garip siteye denk gelmişim :)

Rich (BB code): 
For Each tr In html.getElementById("gungun").getElementsByTagName("ul")
    For Each td In tr.getElementsByTagName("li")
        DoEvents
        veri = td.innerText
        If satir > 2 And sutun > 1 Then
            syf.Cells(satir, sutun).Value = Split(veri, vbCrLf)(1)
        Else
            syf.Cells(satir, sutun).Value = veri
        End If
        sutun = sutun + 1
    Next
    satir = satir + 1
    sutun = 1
Next
 
Olumlu oy 0 Negatif oyla
aşağıdaki gibi dener misiniz hocam?
Kod: 
    For Each tr In html.getElementById("gungun").getElementsByTagName("ul")
        For Each td In tr.getElementsByTagName("li")
        tmp = td.innerText
            For Each Spn In td.getElementsByTagName("span")
                tmp = Spn.NextSibling.Data
            Next Spn

            syf.Cells(satir, sutun).Value = tmp
            sutun = sutun + 1
        Next
        satir = satir + 1
        sutun = 1
    Next
 
Olumlu oy 1 Negatif oyla
Çözüm
Teşekkürler halily abey konu çözüldü :)

İnterntten veri çekme olayıda zevkliymiş belki anlamadıklarım olursa konu açarım.
 
Olumlu oy 0 Negatif oyla
Rica ederim
iyi çalışmalar
bu da diziye aktarılmış hali
Kod: 
Sub TAbloAL1Dz()
t1 = Timer
    Dim html As Object, syf As Worksheet
    Dim tr As Object, td As Object, satir As Long, sutun As Byte, x As Byte, son As Long
  
    Set syf = ThisWorkbook.Worksheets("Sayfa1")
    syf.UsedRange.ClearContents
    On Error GoTo hata
  
    Set html = CreateObject("htmlfile")
  
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://takvim.ihya.org/", False
        .send
        html.body.innerHTML = .responseText
    End With
  
    syf.UsedRange.Cells.ClearContents

   'Satir ve sütunlar tablo
    satir = 2
    sutun = 1
Dim DzVkt(2 To 1000, 1 To 10)
    For Each tr In html.getElementById("gungun").getElementsByTagName("ul")
        For Each td In tr.getElementsByTagName("li")
        tmp = td.innerText
            For Each Spn In td.getElementsByTagName("span")
                tmp = Spn.NextSibling.Data
            Next Spn
            DzVkt(satir, sutun) = tmp
'            syf.Cells(satir, sutun).Value = tmp
            sutun = sutun + 1
        Next
        satir = satir + 1
        sutun = 1
    Next
   syf.Range("A2").Resize(satir, 10) = DzVkt
    GoTo sonsub
  
hata:
  MsgBox "Hata olustu", vbCritical, "Hata"
sonsub:
  Set syf = Nothing: Set html = Nothing: Set tr = Nothing: Set td = Nothing
Debug.Print 2, Timer - t1
End Sub
 
Son düzenleme:
Olumlu oy 0 Negatif oyla
halily' Alıntı:
Rica ederim
iyi çalışmalar
bu da diziye aktarılmış hali
Kod: 
Sub TAbloAL1Dz()
t1 = Timer
    Dim html As Object, syf As Worksheet
    Dim tr As Object, td As Object, satir As Long, sutun As Byte, x As Byte, son As Long
 
    Set syf = ThisWorkbook.Worksheets("Sayfa1")
    syf.UsedRange.ClearContents
    On Error GoTo hata
 
    Set html = CreateObject("htmlfile")
 
    With CreateObject("MSXML2.XMLHTTP")
        .Open "GET", "https://takvim.ihya.org/", False
        .send
        html.body.innerHTML = .responseText
    End With
 
    syf.UsedRange.Cells.ClearContents

   'Satir ve sütunlar tablo
    satir = 2
    sutun = 1
Dim DzVkt(2 To 1000, 1 To 10)
    For Each tr In html.getElementById("gungun").getElementsByTagName("ul")
        For Each td In tr.getElementsByTagName("li")
        tmp = td.innerText
            For Each Spn In td.getElementsByTagName("span")
                tmp = Spn.NextSibling.Data
            Next Spn
            DzVkt(satir, sutun) = tmp
'            syf.Cells(satir, sutun).Value = tmp
            sutun = sutun + 1
        Next
        satir = satir + 1
        sutun = 1
    Next
   syf.Range("A2").Resize(satir, 10) = DzVkt
    GoTo sonsub
 
hata:
  MsgBox "Hata olustu", vbCritical, "Hata"
sonsub:
  Set syf = Nothing: Set html = Nothing: Set tr = Nothing: Set td = Nothing
Debug.Print 2, Timer - t1
End Sub
Genişletmek için tıkla...
Sağol abey.
Ben extra dizi yada scripting=false ve true eklememiştim çünkü butona tıklayınca verilerin süzüle süzüle gelmesini izlemek heyecanlıydı :)
Böyle daha hızlı tabii.
 
Olumlu oy 0 Negatif oyla
halily' Alıntı:
Screenupdate false yapınca diziye almadan daha hızlı aliyor
Genişletmek için tıkla...
Redim içindeki yani redim arr(1 to satır,1 to1) burdaki satır yazan nekadar çoksa fazla sürer.Ben genelde garanti olsun diye rows.count ekliyorum.preserve ile yapılınca bu kezde transposeden dolayı 65536 olayı sorun çıkarıyor abey.
Aetık biraz denemer yapayım başka siterlede yapabilecekmiyim bu veri çekmeyi artık :)
Ama mantığı çözdüm :)
 
Olumlu oy 0 Negatif oyla
halily' Alıntı:
bu durumda en az 65.000 satırlık bir dizi oluşturulmuş olmuyor mu?
Genişletmek için tıkla...
2003 için 65536 diğerler için 1048576 biliyorum.
Dediğim gibi genelde ben böyle yapıyorum belki 1 saniye fark ediyor.
Satır sayısı belliyse o kadarda yazılır.
Litbox yada combo ya zaten zorunlu olmadıkça prerve kullanıyorum orda transpose ye gerek olmadığı için 65536 sorunda olmuyor.
Yada abey bu dosyada alttaki kafadan yazacağım örnek kalıpla preserve olarak yazılınca rows.countada gerek olmaz bildiğiniz gibi.

Kod: 
Redim arr(1 to 1 ,1 to 1)

Döngü içinede

Say =say +1
Redim preserve arr(1 to 10,1 to say)
Arr(1,say)=1
Arr(2,say)=6

Bunlar döngüyede alınabilir.Yazdığım gibi zaten biliyorsunuz.Bu şekilde en başta redime sayı girmeye gerek kalmaz 1000 yada başka.
Bu şekilde yapınca listbox için

Listbox1.column= arr

Yazmak yeterli transposeye gerek kalmadan yada column yerine list yazılabilinir.
Sayfaya aktarmak için ise

Sayfa1.cells(1,1).resize(ubound(arr,2),ubound(arr,1)).value= application.transpose(arr)

Olarak yapılabilinir.Dediğim gibi mobilden kafadan yazdığım için mantık hatası yada kod yazma hatası olabilir abey.
 
Olumlu oy 0 Negatif oyla
Durum
Konu Çözümlendiği İçin Kapatılmıştır.
Geri
Üst