Web den Altın Fiatlarını Almak

halit3 · 11 Ağustos 2014

Aşağıdaki web sitesindeki Altın Fiatlarını almak ile ilgili çalışmam.

14.08.2014 21:22 de güncellendi

http://www.altinpiyasa.com/

halit3 · 11 Ağustos 2014

İlgili web sitesindeki aynı güne ait Altın Fiatlarını almak ile ilgili kod:

Kod:

Sub altın_fiatları1()
Dim URL As String

Dim IE As Object

Range("A2:f5000").ClearContents
Range("A2:f5000").NumberFormat = "General"

URL = "http://www.altinpiyasa.com/"
Set IE = CreateObject("InternetExplorer.Application")

With IE
.Navigate URL
.Visible = 1
ShowWindow IE.hWnd, 6
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop

Do Until IE.ReadyState = 4: DoEvents: Loop

'On Error Resume Next
sat = 2


Set t = IE.Document.all.tags("table").Item(2)
If t.Rows.Length > 1 Then
For i = 0 To t.Rows.Length - 1
For j = 0 To t.Rows(i).Cells.Length - 1
If IsNumeric(t.Rows(i).Cells(j).InnerText) = True Then
Cells(sat, j + 1) = t.Rows(i).Cells(j).InnerText * 1
Else
Cells(sat, j + 1) = t.Rows(i).Cells(j).InnerText
End If
Next
sat = sat + 1
Next
Else
Cells(sat, 1) = Format(Now, "dd.mm.yyyy")
Cells(sat, 2) = "Tatil günü işlem yok"
sat = sat + 1
End If




IE.Quit: Set IE = Nothing
End With

MsgBox ("Bitti  ")
End Sub

halit3 · 11 Ağustos 2014

İlgili web sitesindeki Geçmiş tarihlerle ilgili (A1 hucresindeki tarih günene ait) Altın Fiatlarını almak ile ilgili kod:

Kod:

Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long

Sub altın_fiatları2()
Dim URL As String
Dim IE As Object

Tarih = Cells(1, 1).Value

If IsDate(Tarih) = False Then MsgBox "Başlangıç tarihi yanlış": Exit Sub

'If "Cumartesi" = Format(Tarih, "dddd") Or "Pazar" = Format(Tarih, "dddd") Then GoSub atla
'If "01.01" = Format((Tarih), "dd/mm") And "23.04" = Format((Tarih), "dd/mm") And "01.05" = Format((Tarih), "dd/mm") And "19.05" = Format((Tarih), "dd/mm") _
And "30.08" = Format((Tarih), "dd/mm") And "28.10" = Format((Tarih), "dd/mm") And "29.10" = Format((Tarih), "dd/mm") Then


Range("A2:f5000").ClearContents
Range("A2:f5000").NumberFormat = "General"


gun = Val(Mid(Tarih, 1, 2))
Ay = Val(Mid(Tarih, 4, 2))
yıl = Val(Mid(Tarih, 7, 4))

URL = "http://www.altinpiyasa.com/1+" & Ay & "-" & gun & "-" & yıl & ".html"
Set IE = CreateObject("InternetExplorer.Application")

With IE
.Navigate URL
.Visible = 1
ShowWindow IE.hWnd, 6
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop

Do Until IE.ReadyState = 4: DoEvents: Loop

'On Error Resume Next
sat = 2
yer = sat

Set t = IE.Document.all.tags("table").Item(4)
If t.Rows.Length > 1 Then
For i = 0 To t.Rows.Length - 1
For j = 0 To t.Rows(i).Cells.Length - 1
If IsNumeric(t.Rows(i).Cells(j).InnerText) = True Then
Cells(sat, j + 1) = t.Rows(i).Cells(j).InnerText * 1
Else
Cells(sat, j + 1) = t.Rows(i).Cells(j).InnerText
End If
Next
sat = sat + 1
Next
Cells(yer, 1) = Tarih
Else

Cells(sat, 1) = Tarih
Cells(sat, 2) = "Tatil günü işlem yok"
sat = sat + 1
End If

IE.Quit: Set IE = Nothing
End With
MsgBox ("Bitti  ")
'Exit Sub
'atla:
'MsgBox "Bugün tatil günü işlem yok"
End Sub

halit3 · 11 Ağustos 2014

İlgili web sitesindeki Geçmiş tarihlerle ilgili iki tarih arası (A1 hucresi be B1 hucresi arası tarih günlerine ait) Altın Fiatlarını almak ile ilgili kod:

Kod:

Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long

Sub altın_fiatları3()
Dim URL As String
Dim IE As Object


baslangıc = Cells(1, 1).Value
bitis = Cells(1, 2).Value


If IsDate(baslangıc) = False Then MsgBox "Başlangıç tarihi yanlış": Exit Sub
If IsDate(bitis) = False Then MsgBox "Bitiş tarihi yanlış": Exit Sub

If CDate(baslangıc) <= CDate(bitis) Then
yer1 = CDate(baslangıc)
yer2 = CDate(bitis)
Else
yer2 = CDate(baslangıc)
yer1 = CDate(bitis)
End If

Range("A2:f5000").ClearContents
Range("A2:f5000").NumberFormat = "General"

URL = "http://www.altinpiyasa.com/"
Set IE = CreateObject("InternetExplorer.Application")
sat = 2

With IE
.Navigate URL
.Visible = 1
ShowWindow IE.hWnd, 6
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop
Do Until IE.ReadyState = 4: DoEvents: Loop

For M = 0 To Val(yer2 - yer1)
Tarih = yer1 + M

'If "Cumartesi" = Format(Tarih, "dddd") Or "Pazar" = Format(Tarih, "dddd") Then Cells(sat, 1) = Tarih: Cells(sat, 2) = "Tatil günü işlem yok": sat = sat + 1: GoSub atla
'If "01.01" = Format((Tarih), "dd/mm") And "23.04" = Format((Tarih), "dd/mm") And "01.05" = Format((Tarih), "dd/mm") And "19.05" = Format((Tarih), "dd/mm") _
And "30.08" = Format((Tarih), "dd/mm") And "28.10" = Format((Tarih), "dd/mm") And "29.10" = Format((Tarih), "dd/mm") Then Cells(sat, 1) = Tarih: Cells(sat, 2) = "Tatil günü işlem yok": sat = sat + 1: GoSub atla

gun = Val(Mid(Tarih, 1, 2))
Ay = Val(Mid(Tarih, 4, 2))
yıl = Val(Mid(Tarih, 7, 4))

URL1 = "http://www.altinpiyasa.com/1+" & Ay & "-" & gun & "-" & yıl & ".html"
.Navigate URL1

Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop

yer = sat

Set t = IE.Document.all.tags("table").Item(4)
If t.Rows.Length > 1 Then
For i = 0 To t.Rows.Length - 1
For j = 0 To t.Rows(i).Cells.Length - 1
If IsNumeric(t.Rows(i).Cells(j).InnerText) = True Then
Cells(sat, j + 1) = t.Rows(i).Cells(j).InnerText * 1
Else
Cells(sat, j + 1) = t.Rows(i).Cells(j).InnerText
End If
Next
sat = sat + 1
Next
Cells(yer, 1) = Tarih
Else
Cells(sat, 1) = Tarih
Cells(sat, 2) = "Tatil günü işlem yok"
sat = sat + 1
End If

'atla:
Next

IE.Quit: Set IE = Nothing
End With

MsgBox ("Bitti  ")

End Sub

halit3 · 11 Ağustos 2014

İlgili web sitesindeki Geçmiş tarihlerle ilgili iki tarih arası (A1 hucresi be B1 hucresi arası tarih günlerine ait) Altın Fiatlarını sayfayı silmeden alt alta almak ile ilgili kod:

Kod:

Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long

Sub altın_fiatları4()
Dim URL As String
Dim IE As Object


baslangıc = Cells(1, 1).Value
bitis = Cells(1, 2).Value


If IsDate(baslangıc) = False Then MsgBox "Başlangıç tarihi yanlış": Exit Sub
If IsDate(bitis) = False Then MsgBox "Bitiş tarihi yanlış": Exit Sub

If CDate(baslangıc) <= CDate(bitis) Then
yer1 = CDate(baslangıc)
yer2 = CDate(bitis)
Else
yer2 = CDate(baslangıc)
yer1 = CDate(bitis)
End If


URL = "http://www.altinpiyasa.com/"
Set IE = CreateObject("InternetExplorer.Application")


If WorksheetFunction.CountA(Cells) > 0 Then
sat = Cells.Find(What:="*", After:=[A1], SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row + 2
Else
sat = 2
End If


With IE
.Navigate URL
.Visible = 1
ShowWindow IE.hWnd, 6
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop
Do Until IE.ReadyState = 4: DoEvents: Loop

For M = 0 To Val(yer2 - yer1)
Tarih = yer1 + M

'If "Cumartesi" = Format(Tarih, "dddd") Or "Pazar" = Format(Tarih, "dddd") Then Cells(sat, 1) = Tarih: Cells(sat, 2) = "Tatil günü işlem yok": sat = sat + 1: GoSub atla
'If "01.01" = Format((Tarih), "dd/mm") And "23.04" = Format((Tarih), "dd/mm") And "01.05" = Format((Tarih), "dd/mm") And "19.05" = Format((Tarih), "dd/mm") _
And "30.08" = Format((Tarih), "dd/mm") And "28.10" = Format((Tarih), "dd/mm") And "29.10" = Format((Tarih), "dd/mm") Then Cells(sat, 1) = Tarih: Cells(sat, 2) = "Tatil günü işlem yok": sat = sat + 1: GoSub atla

gun = Val(Mid(Tarih, 1, 2))
Ay = Val(Mid(Tarih, 4, 2))
yıl = Val(Mid(Tarih, 7, 4))

URL1 = "http://www.altinpiyasa.com/1+" & Ay & "-" & gun & "-" & yıl & ".html"
.Navigate URL1

Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop

yer = sat

Set t = IE.Document.all.tags("table").Item(4)
If t.Rows.Length > 1 Then
For i = 0 To t.Rows.Length - 1
For j = 0 To t.Rows(i).Cells.Length - 1
If IsNumeric(t.Rows(i).Cells(j).InnerText) = True Then
Cells(sat, j + 1) = t.Rows(i).Cells(j).InnerText * 1
Else
Cells(sat, j + 1) = t.Rows(i).Cells(j).InnerText
End If
Next
sat = sat + 1
Next
Cells(yer, 1) = Tarih
sat = sat + 1
Else
Cells(sat, 1) = Tarih
Cells(sat, 2) = "Tatil günü işlem yok"
sat = sat + 1
End If

'atla:

Next

IE.Quit: Set IE = Nothing
End With

MsgBox ("Bitti  ")

End Sub


Sub temizle()
Range("A2:f5000").ClearContents
Range("A2:f5000").NumberFormat = "General"
End Sub

halit3 · 12 Ağustos 2014

1 nolu mesajdaki dosya güncellendi

Zeki Gürsoy · 12 Ağustos 2014

Müsanizle bu başlığa ben de katkıda bulunmak isterim Halit bey.

Module1:

Kod:

Sub test()
    Dim s As Sonuc
    
    s = FiyatlarıAl("11.08.2014", Satis)

    MsgBox s.AltinFiyati & " ---  " & s.CumhuriyetAltinFiyati
End Sub

Module2:

Kod:

Public Type Sonuc
    AltinFiyati           As Double
    CeyrekAltinFiyati     As Double
    CumhuriyetAltinFiyati As Double
End Type

Public Enum AlisSatis
    Alis = 1
    Satis = 2
End Enum

Public Function FiyatlarıAl(ByVal tarih As Date, Optional ByVal Alis_Satis As AlisSatis = AlisSatis.Alis) As Sonuc
    Dim t As Object, obj As Object, d As Object
    
    Set x = CreateObject("msxml2.xmlhttp")
    Set d = CreateObject("htmlfile")
    
    x.Open "get", "http://www.altinpiyasa.com/1+" & Format(tarih, "m-d-yyyy"), False
    x.send
    
    d.write StrConv(x.responsebody, vbUnicode)
    
    Set obj = d.getElementById("contentAR")
    
    If Not obj Is Nothing Then
        Set t = obj.getElementsByTagName("table").Item(0)
        
        If Alis_Satis = Alis Then
            FiyatlarıAl.AltinFiyati = t.Rows(1).Cells(1).innerText
            FiyatlarıAl.CeyrekAltinFiyati = t.Rows(2).Cells(1).innerText
            FiyatlarıAl.CumhuriyetAltinFiyati = t.Rows(3).Cells(1).innerText
        Else
            FiyatlarıAl.AltinFiyati = t.Rows(1).Cells(2).innerText
            FiyatlarıAl.CeyrekAltinFiyati = t.Rows(2).Cells(2).innerText
            FiyatlarıAl.CumhuriyetAltinFiyati = t.Rows(3).Cells(2).innerText
        End If
    End If
    
    x.abort
End Function

mancubus · 13 Ağustos 2014

teşekkürler.

halit3 · 14 Ağustos 2014

1 nolu mesajdaki dosya güncellendi

1mak1mak · 22 Ekim 2021

Halit bey merhaba
Eski çalışmanız çok güzel çalışma ancak tam çalışmıyor güncellenirse güzel olur.
Başka bir konudaki Haluk beyin günlük verileri çeken dosyasını kullanıyorum iki tarih arasında da kullanabilsek iyi olur.
Birde bir sorum olacak Altın Dolar Euro sayfalarındaki Grafikleri buton ekleyerek gösterme imkanı olurmu.

Web den Altın Fiatlarını Almak

halit3

Uzman

Ekli dosyalar

halit3

Uzman

halit3

Uzman

halit3

Uzman

halit3

Uzman

halit3

Uzman

Zeki Gürsoy

Uzman

mancubus

Destek Ekibi

halit3

Uzman

1mak1mak

Ekli dosyalar