Altın Euro ve Dolar Gün İçinde En Düşük ve En Yüksek Değerler

ALTINYAYLA · 16 Ağustos 2018

Merhabalar Arkadaşlar Benim ödemem gereken 3 değişik kalemden borçlarım var. Altın Euro ve Dolar ve günlük cüzi miktarlarda ödeme yapıyorum. Anlık fiyatları öğrenebileceğim ve (tabi olabilirliği varsa) içinde bulunulan günün en yüksek ve en düşük değerlerinin tek bir sayfaya gün gün her satır bir gün olmak üzere otomatik eklenmesini istiyorum. Bu konuda bilgisi olan arkadaşlarımın bilgilerinden istifade etmek istiyorum. Bu mümkünmüdür... Eğer mümkünse müteşekkir olurum. bu örnek dosyada 3 sayfa var ben bunu tek sayfada olmasını istiyorum ve euro dolar altın üçüde aynı sayfada...

ALTINYAYLA · 18 Ağustos 2018

Üstadlarımın ilgisine arz ediyorum ...

halit3 · 18 Ağustos 2018

Bu kodu bir dene verileri sayfaya alıyor buradan da yapmak istediğinizi sonradan yaparsınız.

PHP:

Sub deneme()

Dim URL As String
Dim ie As Object

Range("A2:E5000").ClearContents
sat = 1

URL = "https://dovizborsa.com/altin/"
Set ie = CreateObject("InternetExplorer.Application")


ie.Navigate URL
ie.Visible = 1
ie.Width = 400
ie.Height = 850
ie.Left = 10
ie.Top = 0

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

Set veriCollection = ie.document.getElementsByTagName("p")

For Each veri In veriCollection

If veri.className = "-cd-" Then
sat = sat + 1
Cells(sat, 1) = Replace(Replace(WorksheetFunction.Trim(veri.InnerText), Chr(13), ""), Chr(10), " ")
End If
If veri.className = "-nm-" Then
Cells(sat, 2) = Replace(Replace(WorksheetFunction.Trim(veri.InnerText), Chr(13), ""), Chr(10), " ")
End If
If veri.className = "-by-" Then
Cells(sat, 3) = Replace(Replace(WorksheetFunction.Trim(veri.InnerText), Chr(13), ""), Chr(10), " ") * 1
End If
If veri.className = "-sl-" Then
Cells(sat, 4) = Replace(Replace(WorksheetFunction.Trim(veri.InnerText), Chr(13), ""), Chr(10), " ") * 1
End If
If veri.className = "-cl-" Then
Cells(sat, 5) = Replace(Replace(WorksheetFunction.Trim(veri.InnerText), Chr(13), ""), Chr(10), " ") * 1
End If

Next

ie.Quit: Set ie = Nothing


MsgBox ("Bitti  ")
End Sub

Haluk · 18 Ağustos 2018

Halit Bey;

Bu tür web sayfası yapılarında IE yerine XMLHTTP kullanmak hem kodu hızlandırır, hem IE nedeniyle oluşabilecek hatalarından kurtulmuş olursunuz.

.

ALTINYAYLA · 19 Ağustos 2018

Halit hocam benim amacım bahsettiğim işi tek bir sayfada yapmak 3 sayfayı teke düşürmek bu birinci husus bir diğer husus ise bu kodu nereye yapıştıracağım. Alakanız için şimdiden teşekkür ederim..

halit3 · 19 Ağustos 2018

Bu dosyayı irdeleyiniz.
Veriler sayfa1 alınıyor siz sayfa2 ve sayfa3 e ne gibi işlem yapmak istiyorsanız örnek dosya ile açıklamaya çalışın burada en yüksek veya en düşük hangisi oluyor en düşük veya en yüksek hesaplarken hangi veriler hesaplanıyor.

PHP:

Sub veri_al_1()

Dim xmlhttp As Object, URL As String

Set xmlhttp = CreateObject("MSXML2.XMLHTTP")
URL = "https://dovizborsa.com/altin/"

xmlhttp.Open "GET", URL, False
xmlhttp.send

hucre = xmlhttp.responseText

veri1 = ">"
veri2 = "="
veri3 = "</p>"
veri4 = """"
veri5 = ""

ara1 = "-row _"
ara2 = "-nm-"
ara3 = "-by-"
ara4 = "-sl-"
ara5 = "-cl-"

Range("A1:E5000").ClearContents
Range("A1:E1") = Array("Kod", "ALTIN", "ALIŞ", "SATIŞ", "KAPANIŞ")
sat = 2

deg1 = Split(hucre, ara1)
If UBound(deg1) > 0 Then
For k = 1 To UBound(deg1) - 1

deg2 = Split(deg1(k), veri1)
If UBound(deg2) > 0 Then
Cells(k + 1, 1).Value = Replace(Split(deg2(0), veri2)(1), veri4, veri5)
End If

deg3 = Split(deg1(k), ara2)
If UBound(deg3) > 0 Then
Cells(k + 1, 2).Value = Replace(Split(deg3(1), veri3)(0), veri4 & veri1, veri5)
End If

deg4 = Split(deg1(k), ara3)
If UBound(deg4) > 0 Then
Cells(k + 1, 3).Value = Replace(Split(deg4(1), veri3)(0), veri4 & veri1, veri5) * 1
End If

deg5 = Split(deg1(k), ara4)
If UBound(deg5) > 0 Then
Cells(k + 1, 4).Value = Replace(Split(deg5(1), veri3)(0), veri4 & veri1, veri5) * 1
End If

deg6 = Split(deg1(k), ara5)
If UBound(deg6) > 0 Then
Cells(k + 1, 5).Value = Replace(Split(deg6(1), veri3)(0), veri4 & veri1, veri5) * 1
End If

sat = sat + 1
Next k
End If
MsgBox "İşlem Tamam"

Haluk · 19 Ağustos 2018

Merhaba;

Sanırım gerekli olan veriler sadece, spot piyasada Dolar ve Euro ile Altın'ın Dolar bazında Ons değeri ...

O zaman, aşağıdaki kod bu verilerle ilgili bilgileri (alış, satış, kapanış, değişim oranı, son işlem saati) https://dovizborsa.com/altin/ adresinden çeker.

Bu kod tabii ki, soruyu soran arkadaşın beklediği cevap değil, çünkü o zaten bu verileri bir şekilde Web Query ile sayfaya alıyor. Aşağıdaki kod ise; Halit Bey gibi söz konusu dış veri almaya alternatif bir yaklaşım oluşturmak, işi hızlandırmak için hazırlanmıştır.

Kod:

Sub GetData()
    ' Haluk-19/08/2018
    '
    Dim HTTP As Object, HTML As Object
    Dim URL As String
    Dim USDTRY As Object, EURTRY As Object, XAUUSD As Object
   
    Range("A1:G" & Rows.Count) = Empty
   
    URL = "https://dovizborsa.com/altin"
   
    Set HTTP = CreateObject("MSXML2.XMLHTTP")
    Set HTML = CreateObject("HTMLFILE")
   
    HTTP.Open "GET", URL, False
    HTTP.send
   
    If HTTP.Status = 200 Then
        HTML.body.innerHTML = HTTP.responseText
        
        Range("B1:G1") = Array("Kod", "Alış", "Satış", "Kapanış", "%", "Saat")
        Range("B1:G1").Font.Bold = True
        
        Set USDTRY = HTML.getelementByID("USDTRY")
        Range("A2") = USDTRY.Children(0).Children(0).Title
        Range("B2") = USDTRY.Children(0).innerText
        Range("C2") = USDTRY.Children(1).innerText + 0
        Range("D2") = USDTRY.Children(2).innerText + 0
        Range("E2") = USDTRY.Children(3).innerText + 0
        Range("F2") = USDTRY.Children(4).innerText + 0
        Range("G2") = USDTRY.Children(5).innerText
        
        Set EURTRY = HTML.getelementByID("EURTRY")
        Range("A3") = EURTRY.Children(0).Children(0).Title
        Range("B3") = EURTRY.Children(0).innerText
        Range("C3") = EURTRY.Children(1).innerText + 0
        Range("D3") = EURTRY.Children(2).innerText + 0
        Range("E3") = EURTRY.Children(3).innerText + 0
        Range("F3") = EURTRY.Children(4).innerText + 0
        Range("G3") = EURTRY.Children(5).innerText
        
        Set XAUUSD = HTML.getelementByID("XAUUSD")
        Range("A4") = XAUUSD.Children(0).Children(0).Title
        Range("B4") = XAUUSD.Children(0).innerText
        Range("C4") = XAUUSD.Children(1).innerText + 0
        Range("D4") = XAUUSD.Children(2).innerText + 0
        Range("E4") = XAUUSD.Children(3).innerText + 0
        Range("F4") = XAUUSD.Children(4).innerText + 0
        Range("G4") = XAUUSD.Children(5).innerText
    End If
    
    Range("A1:G4").Columns.AutoFit
    Set USDTRY = Nothing
    Set EURTRY = Nothing
    Set XAUUSD = Nothing
    Set HTML = Nothing
    Set HTTP = Nothing
End Sub

Not: Eğer sayfadaki tüm verilerin alınması istenseydi, o zaman hazırlanacak bir For-Next döngüsü ile tüm veriler alınabilirdi.

.

mertahmeth · 19 Ağustos 2018

Ya bu altın üyelik istiyor indiremiyoruz yardımcı olur musunuz

ALTINYAYLA · 21 Ağustos 2018

Yapamadım beceremedim

netzone · 21 Ağustos 2018

ALTINYAYLA1' Alıntı:
Yapamadım beceremedim

Yapamadığınız şey nedir?
Haluk Bey'in kodları ve Halit Bey'in eklediği dosya da veriler sorunsuz geliyor.

ALTINYAYLA · 21 Ağustos 2018

kodları ekleyip dosyanın çalışır halini paylaşırmısın netzone mümkünse...

Haluk · 21 Ağustos 2018

ALTINYAYLA1' Alıntı:
kodları ekleyip dosyanın çalışır halini paylaşırmısın netzone mümkünse...

Benim kodların olduğu dosya ektedir, iyi Bayramlar.

.

ALTINYAYLA · 21 Ağustos 2018

Haluk bey emeklerin için çok teşekkür ederim. Ancak benim istediğim bu değil, benim ilk paylaştığım dosyadaki altın için olanları € ve $ için de almak. yani günde kaç defa yenilenirse yenilensin sadece 1 en düşük ve bir en yüksek veriyi alıyor günde 1 defa ama... Yanılmıyorsam ilk paylaşımımdaki örnek dosyanın kodlarının mimarı Korhan Ayhan Üstadımızdı. Selamlar iyi bayramlar.

ALTINYAYLA · 26 Ağustos 2018

İlk sayfadaki dosya sadece altın için euro ve dolar da eklenecek.

ALTINYAYLA · 5 Aralık 2020

Selam Arkadaşlar, aşağıdaki koda göre Altın Kur, Dolar Kur ve Euro Kur Sayfalarını kullanıyorum. Bunların yanısıra "Gümüş Kur" sayfası da oluşturup fiyatları takip etmek istiyorum. Bu koda gerekli düzenlemeyi yapmak için yeteri kadar kod bilgim bulunmadığından ilgili koda düzenlemeyi yaparsanız sevinirim...

----------------------------------------------------------

Private Sub Worksheet_Calculate()
Dim S1, S2, S3 As Worksheet, Bul1, Bul2, Bul3 As Range, Sat1, Sat2, Sat3 As Long
Dim Mak1, Mak2, Mak3 As Double, Min1, Min2, Min3 As Double

Set wf = WorksheetFunction: Set S1 = Sheets("Dolar Kur")
Set S2 = Sheets("Euro Kur"): Set S3 = Sheets("Altın Kur")

Set Bul1 = S1.Range("A:A").Find(Date)
Set Bul2 = S2.Range("A:A").Find(Date)
Set Bul3 = S3.Range("A:A").Find(Date)

If Not Bul1 Is Nothing Then
Min1 = wf.Min(S1.Range("B" & Bul1.Row, "C" & Bul1.Row), [C2])
Mak1 = wf.Max(S1.Range("B" & Bul1.Row, "C" & Bul1.Row), [C2])
Bul1.Offset(, 1) = Min1: Bul1.Offset(, 2) = Mak1
Else
Sat1 = S1.Cells(Rows.Count, 1).End(3).Row + 1
S1.Cells(Sat1, 1) = Date: S1.Cells(Sat1, 2) = [C2]
End If
If Not Bul2 Is Nothing Then
Min2 = wf.Min(S2.Range("B" & Bul2.Row, "C" & Bul2.Row), [C3])
Mak2 = wf.Max(S2.Range("B" & Bul2.Row, "C" & Bul2.Row), [C3])
Bul2.Offset(, 1) = Min2: Bul2.Offset(, 2) = Mak2
Else
Sat2 = S2.Cells(Rows.Count, 1).End(3).Row + 1
S2.Cells(Sat2, 1) = Date: S2.Cells(Sat2, 2) = [C3]
End If
If Not Bul3 Is Nothing Then
Min3 = wf.Min(S3.Range("B" & Bul3.Row, "C" & Bul3.Row), [C4])
Mak3 = wf.Max(S3.Range("B" & Bul3.Row, "C" & Bul3.Row), [C4])
Bul3.Offset(, 1) = Min3: Bul3.Offset(, 2) = Mak3
Else
Sat3 = S3.Cells(Rows.Count, 1).End(3).Row + 1
S3.Cells(Sat3, 1) = Date: S3.Cells(Sat3, 2) = [C4]
End If
End Sub

ALTINYAYLA · 19 Aralık 2020

Kod yazan ustalardan Yardım talep ediyorum.

Altın Euro ve Dolar Gün İçinde En Düşük ve En Yüksek Değerler

ALTINYAYLA

Ekli dosyalar

ALTINYAYLA

halit3

Uzman

Haluk

Özel Üye

ALTINYAYLA

halit3

Uzman

Ekli dosyalar

Haluk

Özel Üye

mertahmeth

ALTINYAYLA

netzone

ALTINYAYLA

Haluk

Özel Üye

Ekli dosyalar

ALTINYAYLA

ALTINYAYLA

ALTINYAYLA

ALTINYAYLA