Soru Macro hata veriyor

Haluk

𐱅𐰇𐰼𐰚
Katılım
7 Temmuz 2004
Mesajlar
12,269
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Amin, cok tesekkurler O. Faruk Bey.
Sagolun, Allah cumlemixe saglik sfa versin insallah.
 

muratboz06

Destek Ekibi
Destek Ekibi
Katılım
23 Mart 2017
Mesajlar
552
Excel Vers. ve Dili
Office365 TR
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
 
Katılım
17 Haziran 2008
Mesajlar
1,836
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
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.
 

muratboz06

Destek Ekibi
Destek Ekibi
Katılım
23 Mart 2017
Mesajlar
552
Excel Vers. ve Dili
Office365 TR
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.
 

Haluk

𐱅𐰇𐰼𐰚
Katılım
7 Temmuz 2004
Mesajlar
12,269
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Hamit Bey, Murat Bey çok teşekkür ederim.

.
 

EmrExcel16

Destek Ekibi
Destek Ekibi
Katılım
1 Kasım 2012
Mesajlar
1,520
Excel Vers. ve Dili
Office 365 Türkçe
Çok geçmiş olsun Haluk hocam, inşallah tez zamanda sağlığınıza kavuşursunuz.
 

Haluk

𐱅𐰇𐰼𐰚
Katılım
7 Temmuz 2004
Mesajlar
12,269
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
Teşekkürler Emre Bey

.
 

Haluk

𐱅𐰇𐰼𐰚
Katılım
7 Temmuz 2004
Mesajlar
12,269
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
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
.
 
Katılım
17 Haziran 2008
Mesajlar
1,836
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
@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
 

Haluk

𐱅𐰇𐰼𐰚
Katılım
7 Temmuz 2004
Mesajlar
12,269
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
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:
Katılım
17 Haziran 2008
Mesajlar
1,836
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
Anladım. Peki Hocam ikinci tablo ? yani Dolar ve Euro kuru onuda 4 satır atlayıp, yazdırabilirmiyiz ? aynı sayfaya
 

Haluk

𐱅𐰇𐰼𐰚
Katılım
7 Temmuz 2004
Mesajlar
12,269
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
En son mesajdaki kod, bu işi yapıyor...

.
 
Katılım
17 Haziran 2008
Mesajlar
1,836
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
Hocam çok teşekkür ediyorum, yine çok süper bi çözüm... Saygılar sunuyorum.
 
Katılım
17 Haziran 2008
Mesajlar
1,836
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
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
 

Haluk

𐱅𐰇𐰼𐰚
Katılım
7 Temmuz 2004
Mesajlar
12,269
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
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:
Katılım
17 Haziran 2008
Mesajlar
1,836
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
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...
 

Haluk

𐱅𐰇𐰼𐰚
Katılım
7 Temmuz 2004
Mesajlar
12,269
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
+
Google Sheets
+
JScript
36 No'lu mesajdaki kodu revize ettim....

.
 
Katılım
17 Haziran 2008
Mesajlar
1,836
Excel Vers. ve Dili
Microsoft Ofis Profesyonel 2019 x64 TR
Gördüm Hocam . Stabil bir şekilde çalıyor. değerleride kontrol ettim.

Elinize sağlık. Tamamdır.
 
Katılım
9 Ocak 2011
Mesajlar
354
Excel Vers. ve Dili
2007 Türkçe
36 No'lu mesajdaki kodu revize ettim....

.
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 = "@"
 
Üst