• 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
Amin, cok tesekkurler O. Faruk Bey.
Sagolun, Allah cumlemixe saglik sfa versin insallah.
 
Haluk Bey geçmiş olsun, Allah şifa versin.

Tools>References ten Microsoft HTML Object Library ve Microsoft Internet Controls kütüphaneleri aktif ediniz.
İhtiyacınıza göre kodda düzeltme yaparsınız.
Kod: 
Sub TabloAl()
    Dim HTMLDoc     As New HTMLDocument
    Dim objTable    As Object
    Dim lRow        As Long
    Dim lngTable    As Long
    Dim lngRow      As Long
    Dim lngCol      As Long
    Dim ActRw       As Long
    Dim objIE       As InternetExplorer
    Set objIE = New InternetExplorer
    objIE.navigate "http://www.altinpiyasa.com/"
   
    Do Until objIE.readyState = 4 And Not objIE.Busy
        DoEvents
    Loop
    ActiveSheet.UsedRange.ClearContents
   
    Application.Wait (Now + TimeValue("0:00:03"))
    HTMLDoc.body.innerHTML = objIE.document.body.innerHTML
    With HTMLDoc.body
        Set objTable = .getElementsByTagName("table")
        For lngTable = 0 To objTable.Length - 1
            For lngRow = 0 To objTable(lngTable).Rows.Length - 1
                For lngCol = 0 To objTable(lngTable).Rows(lngRow).Cells.Length - 1
                    ActiveSheet.Cells(ActRw + lngRow + 1, lngCol + 1) = objTable(lngTable).Rows(lngRow).Cells(lngCol).innerText
                Next lngCol
            Next lngRow
            ActRw = ActRw + objTable(lngTable).Rows.Length + 1
        Next lngTable
    End With
    objIE.Quit
    On Error Resume Next
    ActiveSheet.UsedRange.Select
    For Each cell In Selection
        cell.Value = cell.Value * 1
    Next cell
   
End Sub
 
Teşekkürler. Kod çalışıyor. fakat Dolar/TL kısmında değer olarak 90.208 gösteriyor. benim dün akşam hazırladığım kodda 90.208 gösteriyor. Bunu anlamadım.. yani tablo 2 de hatalı değerler geliyor.
 
Paylaştığım kod çalıştığı anda ilgili sitedeki tabloyu excele kopyalar.
Hata varsa sitede vardır.
İsterseniz
On Error Resume Next
ActiveSheet.UsedRange.Select
For Each cell In Selection
cell.Value = cell.Value * 1
Next cell
satırlarını silin.
 
Hamit Bey, Murat Bey çok teşekkür ederim.

.
 
Çok geçmiş olsun Haluk hocam, inşallah tez zamanda sağlığınıza kavuşursunuz.
 
Teşekkürler Emre Bey

.
 
Altın verilerini sözkonusu siteden almak için alternatif;

C#: 
Sub getAltin()
'   Haluk - 12/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("B2:F" & Rows.Count) = ""
    
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    strURL = "http://www.altinpiyasa.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(1)
    
    iRow = 1
    For i = 1 To MyTable.Rows.Length - 1
        iRow = iRow + 1
        For j = 1 To MyTable.Rows(i).Cells.Length - 1
            If j < 4 Then
                Cells(iRow, j + 1) = Val(MyTable.Rows(i).Cells(j).innerText)
            Else
                Cells(iRow, j + 1) = MyTable.Rows(i).Cells(j).innerText
            End If
        Next
    Next
    Range("B2:D16").NumberFormat = "#,###.00"
 End Sub

.
 
@Haluk

hocam evet ilk tabloyu alıyor. Fakat çeyrek,tam altın gibi yazan kısımlar gelmedi. birde ikinci tablodaki Dolar ve Euro kurlarınıda alta listeleyebilirsek güzel olur
 
Bahsettiğiniz "çeyrek, tam altın......" vb kısımları özellikle almadım ve verileri bu yüzden 2. satır, 2. sütundan başlayarak sayfaya yazdırdım çünkü onlar sabir etiketler. Siz bir kereliğine onları web sayfasından kopyalayıp, Excel sayfasında 1.satır, 1.. sütuna kopyalayın ...... işlem tamam olacaktır.

Bu şekilde her 2 tabloyu da almak için aşağıdaki kodu kullanabilirsiniz;

C#: 
Sub getAltin()
'   Haluk - 12/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 x As Integer, i As Long, iRow As Long, j As Integer
  
    Range("B2:F16, B20:F22") = ""
  
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    strURL = "http://www.altinpiyasa.com/"
  
    objHTTP.Open "GET", strURL, False
    objHTTP.send

    Set HTML = CreateObject("HTMLFILE")
    HTML.body.innerHTML = objHTTP.responseText
  
    Set Tables = HTML.getElementsByTagName("table")
  
    For x = 1 To 2
        Set MyTable = Tables(x)
      
        iRow = IIf(x = 1, 1, 19)
        For i = 1 To MyTable.Rows.Length - 1
            iRow = iRow + 1
            For j = 1 To MyTable.Rows(i).Cells.Length - 1
                If j < 4 Then
                    Cells(iRow, j + 1) = Val(MyTable.Rows(i).Cells(j).innerText)
                Else
                    Cells(iRow, j + 1) = MyTable.Rows(i).Cells(j).innerText
                End If
            Next
        Next
        Range("B2:D22, B20:D22").NumberFormat = "#,###.00"
    Next
End Sub

2. tablo için de benzer şekilde 19. satır ve 1. sütunda etiketleri bir kereye mahsus mauel olarak siz girersiniz.


.
 
Son düzenleme:
Anladım. Peki Hocam ikinci tablo ? yani Dolar ve Euro kuru onuda 4 satır atlayıp, yazdırabilirmiyiz ? aynı sayfaya
 
En son mesajdaki kod, bu işi yapıyor...

.
 
Hocam çok teşekkür ediyorum, yine çok süper bi çözüm... Saygılar sunuyorum.
 
Hocam veri alımında bazı hatalar fark ettim.

şu şekilde;

tablo2 de sorun yok.

tablo1 de mesela Tam altın değerini 3,2 olarak veriyor... olması gereken : 3.280,71
 
C#: 
Sub getAltin()
'   Haluk - 12/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 x As Integer, i As Long, iRow As Long, j As Integer
 
    Range("B2:F16, B20:F22") = ""
 
    Set objHTTP = CreateObject("MSXML2.ServerXMLHTTP")
    strURL = "http://www.altinpiyasa.com/"
 
    objHTTP.Open "GET", strURL, False
    objHTTP.send

    Set HTML = CreateObject("HTMLFILE")
    HTML.body.innerHTML = objHTTP.responseText
 
    Set Tables = HTML.getElementsByTagName("table")
 
    For x = 1 To 2
        Set MyTable = Tables(x)
      
        iRow = IIf(x = 1, 1, 19)
        For i = 1 To MyTable.Rows.Length - 1
            iRow = iRow + 1
            For j = 1 To MyTable.Rows(i).Cells.Length - 1
                If j < 4 Then
                    Cells(iRow, j + 1) = Replace((MyTable.Rows(i).Cells(j).innerText), ".", "") + 0
                Else
                    Cells(iRow, j + 1) = MyTable.Rows(i).Cells(j).innerText
                End If
            Next
        Next
    Next
    
    Range("B2:F16").NumberFormat = "#.00"
    Range("B20:F22").NumberFormat = "#,##0.0000"
    Range("F2:F22").NumberFormat = "hh:mm;@"
    Range("E2:E22").NumberFormat = "@"
End Sub


.
 
Son düzenleme:
Haluk bey;

Daha da karıştı... sayın abim.

galiba şu kısımdan düzenleyeceğiz : Range("B2 : 22, B20 : 22").NumberFormat = "#,###.00"

bende bakıyorum...
 
36 No'lu mesajdaki kodu revize ettim....

.
 
Gördüm Hocam . Stabil bir şekilde çalıyor. değerleride kontrol ettim.

Elinize sağlık. Tamamdır.
 
Haluk' Alıntı:
36 No'lu mesajdaki kodu revize ettim....

.
Genişletmek için tıkla ...
Haluk hocam elinize sağlık güzel çalışıyor Epeydir IEXPLORER Probleminden Kur Bilgisi çekemiyordum bununla çekebildim.
bende bir soru sorayım Değişim Sütununda Değeri Ortalamak için aşağıdaki Kodda nasıl bir değişiklik gerekir.

Kod: 
Range("E2:E22").NumberFormat = "@"
 
Cevap yazmak için giriş yap yada kayıt ol.
Geri
Üst