• DİKKAT

    DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
    Altın Üyelik Hakkında Bilgi

Soru Macro hata veriyor

  • Konbuyu başlatan Konbuyu başlatan k0081
  • Başlangıç tarihi Başlangıç tarihi
k0081

k0081

Katılım
17 Haziran 2008
Mesajlar
1,874
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
Merhaba arkadaşlar,
daha önceleri sorunsuz çalışan makro, şu kısımda hata veriyor ? :

Set List = HTML.getElementById("list") 'page

Kod: 
Sub DemirAL()

Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    strURL = "https://www.demirfiyatlari.com/"
    
    objHTTP.Open "GET", strURL, False
    objHTTP.send

    Set HTML = CreateObject("htmlFile")
    HTML.body.innerhtml = objHTTP.responseText

Set List = HTML.getElementById("list") 'page

yardımcı olacak arkadaşa şimdiden teşekkürler.
 
Evet olabilir. Bir de site açılışına bir ileti koyulmuş. Bu daha önce yoktu
 
Makro kodunun tamamını paylaşır mısınız, birde ekran görüntüsü ile almak istediğiniz alanı belirtirseniz yardımcı olabiliriz.
 
Kod: 
Sub DemirAL()

Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    strURL = "https://www.demirfiyatlari.com/"
  
    objHTTP.Open "GET", strURL, False
    objHTTP.send

    Set HTML = CreateObject("htmlFile")
    HTML.body.innerhtml = objHTTP.responseText

Set List = HTML.getElementById("list") 'page
Set div = List.GetElementsByTagName("DIV") 'http://www.demirfiyatlari.com/
baslik = div(0).innertext 'Başlık yazısı Günü Tarihini Güncelleme tarihi




a = 3 'Çapları burdan itibaren yaz. yani B3 satırından

'DEMİR ÇAPLARI BAŞI
Set th = List.GetElementsByTagName("TH") 'Q8  Q10 Q12 ve Q32 kısmı
For i = 0 To 3
Sheets("MalzemeGuncelFiyatlar").Cells(a, i + 1) = th(i).innertext
Next i
a = a + 1
'DEMİR ÇAPLARI SONU
  
Range("A1").Value = baslik
Range("A2").Value = "http://www.demirfiyatlari.com/"

Set Tbody = List.GetElementsByTagName("TBODY") 'Tbody ti Internet.App
For Each Tr In Tbody(0).document.all.tags("TR") 'Tbody ti IE yerine kullandım.
For f = 0 To Tr.all.tags("TD").Length - 1
Sheets("MalzemeGuncelFiyatlar").Cells(a, f + 1) = Tr.all.tags("TD").Item(f).innertext 'TD : Demir fiyatları ve iller
Next f
a = a + 1
Next
'.......................... Tbody, TD, TR, TH, Content, Table = bu değişkenlerin hepsi web sitesinin içindeki kodlardıR.
Range("A3").Value = "1 ton Fiyatıdır."
MsgBox "Güleç Demir den Demir Fiyatları Alındı", vbInformation
    Set objHTTP = Nothing
    Set HTML = Nothing
    Set List = Nothing
    Set div = Nothing
    Set th = Nothing
    Set Tbody = Nothing
    Set Tr = Nothing
    Set td = Nothing
End Sub




1tv6n7e.png

ekran1
www.hizliresim.com www.hizliresim.com
 
C#: 
Sub DemirAL2()
'   Haluk - 11/10/2021
'   sa4truss@gmail.com
'   https://excelhaluk.blogspot.com/
    
    Dim objHTTP As Object, strURL As String
    Dim HTML As Object, Tables As Object, Table As Object
    Dim i As Long, iRow As Long, j As Integer
    
    Range("A1:D" & Rows.Count) = ""
    
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    strURL = "https://www.demirfiyatlari.com/"
    
    objHTTP.Open "GET", strURL, False
    objHTTP.send

    Set HTML = CreateObject("htmlFile")
    HTML.body.innerhtml = objHTTP.responseText
    
    Set Tables = HTML.getElementsByTagName("table")
    Set MyTable = Tables(0)
    
    For i = 0 To MyTable.Rows.Length - 1
        iRow = iRow + 1
        For j = 0 To MyTable.Rows(i).Cells.Length - 1
            Cells(iRow, j + 1) = Replace(MyTable.Rows(i).Cells(j).innerText, "TL", "")
        Next
    Next
 End Sub

.
 
@Haluk

Çok Teşekkür ederim , Tamamdır. Elinize sağlık
 
@Haluk

hocam, tablonun ilk başlığındaki : tarih ve kdv dahil nakliye hariç yazan kısım.

Bunu başlık olarak almalıyım. A1 e. Bunu nasıl yapabilirim ? ( formatlı tabloma uyarladım. sadece bu kısım kaldı.)

Range("A1").Value = baslik
 
O zaman ilk önce VBA editörde "Microsoft HTML Object Library" referansını seçeceksiniz.

Daha sonra, eskisinin yerine aşağıdaki kodu kullanacaksınız....

C#: 
Sub DemirAL3()
'   Haluk - 11/10/2021
'   sa4truss@gmail.com
'   https://excelhaluk.blogspot.com/
   
    Dim objHTTP As Object, strURL As String
    Dim HTML As HTMLDocument, Tables As Object, Table As Object
    Dim i As Long, iRow As Long, j As Integer
    Dim xData As Object
   
    Range("A1:D" & Rows.Count) = ""
   
    Set objHTTP = CreateObject("MSXML2.XMLHTTP")
    strURL = "https://www.demirfiyatlari.com/"
   
    objHTTP.Open "GET", strURL, False
    objHTTP.send

    Set HTML = New HTMLDocument
    HTML.body.innerhtml = objHTTP.responseText
   
    Set Tables = HTML.getElementsByTagName("table")
    Set MyTable = Tables(0)
   
    For i = 0 To MyTable.Rows.Length - 1
        iRow = iRow + 1
        For j = 0 To MyTable.Rows(i).Cells.Length - 1
            Cells(iRow, j + 1) = Replace(MyTable.Rows(i).Cells(j).innerText, "TL", "")
        Next
    Next
   
    Set xData = HTML.getElementsByClassName("card-header bg-color-grey text-3")(2)
   
    Range("A1") = xData.innerText
End Sub


.
 
Tamamdır. Hocam çok Teşekkürler., -- Bu akşam için son 1 soru :

sizin daha önce göndermiş olduğunuz kod ile altıpiyasası isimli siteden verileri aldım.

yalnız karakterler Türkçe değil. bunu nasıl düzeltebilirim ?

Ekran resmi ekliyorum

1ax3mgs.png

karakter
www.hizliresim.com www.hizliresim.com
 
Bu akşamlık bu kadar yeter zira; bugün katarakt ameliyatı oldum, tek gözle yardımcı olmaya çalışıyorum....

.
 
Abi tamamdır. Çok geçmiş olsun.
 
Eyvallah....sağolasın.

.
 
Teşekkürler Evren Bey, sağolun...

.
 
Geçmiş olsun üstad. Herşeyin başı sağlık...
 
Eyvallah dostum.... aynen öyle 230758
 
Haluk bey, geçmiş olsun. Bu genç yaşta katarakt oluyor muymuş?
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst