• DİKKAT

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

  • MÜJDE!!!! EXCEL WEB TR Adminlerinden Online EXCEL Seminerleri

    Online eğitimlere başlamadan önce sizlerin görüşlerini almak istiyoruz. Lütfen aşağıdaki konuda görüşlerinizi paylaşır mısınız... TEŞEKKRÜR EDERİZ

    ONLİNE EĞİTİM ANKETİ

Soru Macro hata veriyor

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
10,272
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
Amin, cok tesekkurler O. Faruk Bey.
Sagolun, Allah cumlemixe saglik sfa versin insallah.
 
Katılım
23 Mart 2017
Mesajlar
444
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,555
Excel Vers. ve Dili
Excel 2007-2010 Türkçe
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.
 
Katılım
23 Mart 2017
Mesajlar
444
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

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
10,272
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
Hamit Bey, Murat Bey çok teşekkür ederim.

.
 

EmrExcel16

Destek Ekibi
Destek Ekibi
Katılım
1 Kasım 2012
Mesajlar
1,356
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

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
10,272
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
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,555
Excel Vers. ve Dili
Excel 2007-2010 Türkçe
@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

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
10,272
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
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,555
Excel Vers. ve Dili
Excel 2007-2010 Türkçe
Anladım. Peki Hocam ikinci tablo ? yani Dolar ve Euro kuru onuda 4 satır atlayıp, yazdırabilirmiyiz ? aynı sayfaya
 

Haluk

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
10,272
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
En son mesajdaki kod, bu işi yapıyor...

.
 
Katılım
17 Haziran 2008
Mesajlar
1,555
Excel Vers. ve Dili
Excel 2007-2010 Türkçe
Hocam çok teşekkür ediyorum, yine çok süper bi çözüm... Saygılar sunuyorum.
 
Katılım
17 Haziran 2008
Mesajlar
1,555
Excel Vers. ve Dili
Excel 2007-2010 Türkçe
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

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
10,272
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
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,555
Excel Vers. ve Dili
Excel 2007-2010 Türkçe
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

Özel Üye
Katılım
7 Temmuz 2004
Mesajlar
10,272
Excel Vers. ve Dili
64 Bit 2010 - İngilizce
36 No'lu mesajdaki kodu revize ettim....

.
 
Katılım
17 Haziran 2008
Mesajlar
1,555
Excel Vers. ve Dili
Excel 2007-2010 Türkçe
Gördüm Hocam . Stabil bir şekilde çalıyor. değerleride kontrol ettim.

Elinize sağlık. Tamamdır.
 

1mak1mak

Altın Üye
Katılım
9 Ocak 2011
Mesajlar
268
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