• Foruma hoş geldin 👋 Ziyaretçi

    Forum içeriğine ve tüm hizmetlerimize erişim sağlamak için foruma kayıt olmalı ya da giriş yapmalısınız. Foruma üye olmak tamamen ücretsizdir.

    Giriş yap veya Şimdi kayıt ol

Çözüldü indirilen motorin değerini başka sayfaya da yazma

Bu konu çözüldü olarak işaretlenmiştir. Çözülmediğini düşünüyorsanız konuyu rapor edebilirsiniz.
Durum
Konu Çözümlendiği İçin Kapatılmıştır.
Ortak_Akıl

Ortak_Akıl

Yeni Üye
Katılım
1 Haz 2023
Mesajlar
225
Çözümler
23
Aldığı beğeni
105
Excel V
Office 2013 TR
YAKIT_BILGILERI sayfasına vba ile

<indirirkennaynı anda veya sonradan>

Akaryakıt fiyatları sayfasındaki tarihlerin yanına da yazmak istiyorum.



kod şu şekildedir.

yardımcı olur musunuz..


C#: 
Private Sub CommandButton1_Click()
    On Error Resume Next
    Dim oIE As InternetExplorer
    Dim oHDoc As HTMLDocument
    Const strURL As String = "EBİS Bildirim Sistemi"
    'Application.ScreenUpdating = False
  
    Application.EnableEvents = False
    'Application.Calculation = xlCalculationManual
    Application.Calculation = xlAutomatic
    Application.DisplayAlerts = False
    ss = Cells(Rows.Count, 2).End(xlUp).Row
    If ss > 2 Then Range("C3:C" & ss).ClearContents
    Set oIE = New InternetExplorer
    With oIE
        .Visible = False
        .Navigate strURL
    End With
    Do While oIE.Busy = True Or oIE.readyState <> 4
        DoEvents
    Loop
    Set oHDoc = oIE.Document
    For i = 3 To ss
        valTrh = CStr(Format(Cells(i, 2).Value2, " dd.mm.yyyy"))
        If valTrh = "" Then Exit For
        oHDoc.getElementById("bultenKriterleriForm:j_idt30_input").Value = valTrh
        oHDoc.getElementById("bultenKriterleriForm:j_idt32").Click
        Do While oIE.Busy = True Or oIE.readyState <> 4 Or oIE.readyState <> READYSTATE_COMPLETE
            DoEvents
        Loop
        Application.Wait (Now + TimeValue("0:00:01"))
      
      
        With oHDoc.getElementsByTagName("table")(5)
      
    
      
            Cells(i, 3).Value2 = CDbl(Evaluate(.Rows(3).Cells(1).innerText))
          
    Cells(3, 5) = valTrh
      Cells(4, 5) = "indirilen tarih"
          
        End With
    Next i
        Cells(3, 5) = ""
      Cells(4, 5) = ""
    MsgBox "İşlem tamam.", vbInformation, "ExcelCozum.com"
    oIE.Quit
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    oIE.Quit
    Set oIE = Nothing
    Set oHDoc = Nothing
    Set xlSht = Nothing
End Sub
 

Ekli dosyalar

Çözüm
askan
Akaryakıt fiyatları sayfasına button atayıp aşağıdaki kodu yapıştırıp deneyin. Boş gördüğü fiyatları siteden arar ve getirir. Bulunamayan fiyatların adedini de size bildirir.

Kod: 
Private Sub CommandButton1_Click()
On Error Resume Next
    Dim oIE As InternetExplorer
    Dim oHDoc As HTMLDocument
    Dim y, x As Integer, z As Integer, ss As Long
    Dim ara As Range
    Const strURL As String = "https://bildirim.epdk.gov.tr/bildirim-portal/faces/pages/tarife/petrol/yonetim/bultenSorgula.xhtml"
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.Calculation = xlAutomatic
    Application.DisplayAlerts = False
   
     Set ara =...
Tarihe göre sırala Oylara göre sırala
Şunu dener misiniz:

Kod: 
Private Sub CommandButton1_Click()
    On Error Resume Next
    Dim oIE As InternetExplorer
    Dim oHDoc As HTMLDocument
    Const strURL As String = "https://bildirim.epdk.gov.tr/bildirim-portal/faces/pages/tarife/petrol/yonetim/bultenSorgula.xhtml"
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.Calculation = xlAutomatic
    Application.DisplayAlerts = False
    ss = Cells(Rows.Count, 2).End(xlUp).Row
    If ss > 2 Then Range("C3:C" & ss).ClearContents
    Set oIE = New InternetExplorer
    With oIE
        .Visible = False
        .Navigate strURL
    End With
    Do While oIE.Busy = True Or oIE.readyState <> 4
        DoEvents
    Loop
    Set oHDoc = oIE.Document
    For i = 3 To ss
        valTrh = CStr(Format(Cells(i, 2).Value2, " dd.mm.yyyy"))
        If valTrh = "" Then Exit For
        oHDoc.getElementById("bultenKriterleriForm:j_idt30_input").Value = valTrh
        oHDoc.getElementById("bultenKriterleriForm:j_idt32").Click
        Do While oIE.Busy = True Or oIE.readyState <> 4 Or oIE.readyState <> READYSTATE_COMPLETE
            DoEvents
        Loop
        Application.Wait (Now + TimeValue("0:00:01"))
        
        
        With oHDoc.getElementsByTagName("table")(5)
        
      
      
            Cells(i, 3).Value2 = CDbl(Evaluate(.Rows(3).Cells(1).innerText))
          
    Cells(3, 5) = valTrh
      Cells(4, 5) = "indirilen tarih"
            
        End With
    Next i
        Cells(3, 5) = ""
      Cells(4, 5) = ""
      y = Range("C3:C" & ss).Value
      With Sheets("Akaryakıt fiyatları")
      Set ara = .Range("B:B").Find(What:=Cells(3, 2).Value, LookAt:=xlWhole)
      If Not ara Is Nothing Then
      .Cells(ara.Row, "C").Resize(UBound(y)) = y
      End If
      End With
    MsgBox "İşlem tamam.", vbInformation, "ExcelCozum.com"
    oIE.Quit
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    oIE.Quit
    Set oIE = Nothing
    Set oHDoc = Nothing
    Set xlSht = Nothing
End Sub
 
Olumlu oy 0 Negatif oyla
elinize sağlık. bu şekilde işimi görür.

Fakat sitede arada bazı tarih değerlerine ait motorin değerleri DÜZELTİLMİŞ olduğu için, bu değerler siteden boş olarak iniyor. yani siteden indiremiyor.(yada ekstra program yapılması gerekiyor. bunun yerine Manuel girip kontrol ediyorum) manuel girilme işlemi yapılmadan, tekrar sorgulama butonuna basıldığında indirilen yanlış değerleri akaryakıt sayfasına, son boşluğu bularak yapıştırdığı için, indirilemeyen motorin fiyatından başlıyor. böylelikle yanlış hücrelere yapıştırıyor.


Bu sebeple:
şu şekilde yapılabilir mi: YAKIT_BILGILERI sayfasında b2 hücresindeki tarihe ait,
c2 hücresindeki motorin değerini;
Akaryakıt fiyatları sayfasındaki b sütununda düşeyara ile bularak mesela: tarihi (14.7.2023) e göre adres Cells(1903, 2)' bulmuş ise, ise motorin değerini Cells(1903, 3) ' yapıştırması ve bunun indirirken veya sonradan yapılması mümkün olabilir mi.

yapılamaz ise de yine teşekkür ederim...
 
Olumlu oy 0 Negatif oyla
Hücre boş ise bir üst değeri alacak şekilde ayarladım. Aslında boş gelmesinin sebebi internet bağlantısı ile alakalı olsa gerek.
şu satırdaki rakamı 2 yapıp deneyin derim ancak bekleme süresi artar.
Kod: 
Application.Wait (Now + TimeValue("0:00:01"))

Diğer üstteki açıkladığım şekilde kod:
Kod: 
Private Sub CommandButton1_Click()
    On Error Resume Next
    Dim oIE As InternetExplorer
    Dim oHDoc As HTMLDocument
    Const strURL As String = "https://bildirim.epdk.gov.tr/bildirim-portal/faces/pages/tarife/petrol/yonetim/bultenSorgula.xhtml"
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.Calculation = xlAutomatic
    Application.DisplayAlerts = False
    ss = Cells(Rows.Count, 2).End(xlUp).Row
    If ss > 2 Then Range("C3:C" & ss).ClearContents
    Set oIE = New InternetExplorer
    With oIE
        .Visible = False
        .Navigate strURL
    End With
    Do While oIE.Busy = True Or oIE.readyState <> 4
        DoEvents
    Loop
    Set oHDoc = oIE.Document
    For i = 3 To ss
        valTrh = CStr(Format(Cells(i, 2).Value2, " dd.mm.yyyy"))
        If valTrh = "" Then Exit For
        oHDoc.getElementById("bultenKriterleriForm:j_idt30_input").Value = valTrh
        oHDoc.getElementById("bultenKriterleriForm:j_idt32").Click
        Do While oIE.Busy = True Or oIE.readyState <> 4 Or oIE.readyState <> READYSTATE_COMPLETE
            DoEvents
        Loop
        Application.Wait (Now + TimeValue("0:00:01"))
        
        
        With oHDoc.getElementsByTagName("table")(5)
        
      
      
            Cells(i, 3).Value2 = CDbl(Evaluate(.Rows(3).Cells(1).innerText))
           If Cells(i, 3) = "" Then Cells(i, 3) = Cells(i - 1, 3)
    Cells(3, 5) = valTrh
      Cells(4, 5) = "indirilen tarih"
            
        End With
    Next i
        Cells(3, 5) = ""
      Cells(4, 5) = ""
      y = Range("C3:C" & ss).Value
      With Sheets("Akaryakıt fiyatları")
      Set ara = .Range("B:B").Find(What:=Cells(3, 2).Value, LookAt:=xlWhole)
      If Not ara Is Nothing Then
      .Cells(ara.Row, "C").Resize(UBound(y)) = y
      End If
      End With
    MsgBox "İşlem tamam.", vbInformation, "ExcelCozum.com"
    oIE.Quit
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    oIE.Quit
    Set oIE = Nothing
    Set oHDoc = Nothing
    Set xlSht = Nothing
End Sub
 
Olumlu oy 0 Negatif oyla
Teşekkür ederim elinize sağlık.
not olarak bir ayrıntıyı belirtmek.
motorin değerinin boş gelmesi muhtemel bir durum olabilir. fakat daha çok düzeltme olduğu için değeri okuyamıyor.

bu durumu

adresten
17.07.2023 ve 18.07.2023 tarihindeki motorin değerleri sorgulanınca daha iyi anlaşılabilir.



tekrar teşekkür ederim.
 
Olumlu oy 0 Negatif oyla
Akaryakıt fiyatları sayfasına button atayıp aşağıdaki kodu yapıştırıp deneyin. Boş gördüğü fiyatları siteden arar ve getirir. Bulunamayan fiyatların adedini de size bildirir.

Kod: 
Private Sub CommandButton1_Click()
On Error Resume Next
    Dim oIE As InternetExplorer
    Dim oHDoc As HTMLDocument
    Dim y, x As Integer, z As Integer, ss As Long
    Dim ara As Range
    Const strURL As String = "https://bildirim.epdk.gov.tr/bildirim-portal/faces/pages/tarife/petrol/yonetim/bultenSorgula.xhtml"
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.Calculation = xlAutomatic
    Application.DisplayAlerts = False
   
     Set ara = Range("B:B").Find(What:=CDate(Format(Now, "dd.mm.yy")))
      If Not ara Is Nothing Then
       ss = ara.Row
       Else: MsgBox "Bugünün fiyatı boş olduğu için makro çalışmaz", vbInformation, "ExcelCozum.com"
       GoTo 0
      End If
 
    If ss < 3 Then Exit Sub
    y = Range("B3:C" & ss).Value
   
   
    Set oIE = New InternetExplorer
    With oIE
        .Visible = False
        .Navigate strURL
    End With
    Do While oIE.Busy = True Or oIE.readyState <> 4
        DoEvents
    Loop
    Set oHDoc = oIE.Document
    For i = 1 To UBound(y)
 
    If y(i, 2) = "" Then
    x = x + 1
        valTrh = CStr(Format(y(i, 1), " dd.mm.yyyy"))
        If valTrh = "" Then Exit For
        oHDoc.getElementById("bultenKriterleriForm:j_idt30_input").Value = valTrh
        oHDoc.getElementById("bultenKriterleriForm:j_idt32").Click
        Do While oIE.Busy = True Or oIE.readyState <> 4 Or oIE.readyState <> READYSTATE_COMPLETE
            DoEvents
        Loop
        Application.Wait (Now + TimeValue("0:00:02"))
       
       
           With oHDoc.getElementsByTagName("table")(5)
       
     
     
           y(i, 2) = CDbl(Evaluate(.Rows(3).Cells(1).innerText))
           If y(i, 2) = "" Then z = z + 1
           End With
        End If
    Next i
        If x > 0 Then
      Cells(3, "B").Resize(UBound(y), 2) = y
      If z > 0 Then MsgBox z & " Adet boş Akaryakıt fiyatları bulunamamıştır", vbInformation, "ExcelCozum.com"
      GoTo 0
      Else
      MsgBox "Boş Akaryakıt fiyatları bulunamamıştır", vbInformation, "ExcelCozum.com"
      GoTo 0
      End If
    MsgBox "İşlem tamam.", vbInformation, "ExcelCozum.com"
0:
    oIE.Quit
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    oIE.Quit
    Set oIE = Nothing
    Set oHDoc = Nothing
    Set xlSht = Nothing
End Sub
 
Olumlu oy 1 Negatif oyla
Çözüm
askan' Alıntı:
Akaryakıt fiyatları sayfasına button atayıp aşağıdaki kodu yapıştırıp deneyin. Boş gördüğü fiyatları siteden arar ve getirir. Bulunamayan fiyatların adedini de size bildirir.

Kod: 
Private Sub CommandButton1_Click()
On Error Resume Next
    Dim oIE As InternetExplorer
    Dim oHDoc As HTMLDocument
    Dim y, x As Integer, z As Integer, ss As Long
    Dim ara As Range
    Const strURL As String = "https://bildirim.epdk.gov.tr/bildirim-portal/faces/pages/tarife/petrol/yonetim/bultenSorgula.xhtml"
    Application.ScreenUpdating = False
    Application.EnableEvents = False
    Application.Calculation = xlCalculationManual
    Application.Calculation = xlAutomatic
    Application.DisplayAlerts = False
  
     Set ara = Range("B:B").Find(What:=CDate(Format(Now, "dd.mm.yy")))
      If Not ara Is Nothing Then
       ss = ara.Row
       Else: MsgBox "Bugünün fiyatı boş olduğu için makro çalışmaz", vbInformation, "ExcelCozum.com"
       GoTo 0
      End If
 
    If ss < 3 Then Exit Sub
    y = Range("B3:C" & ss).Value
  
  
    Set oIE = New InternetExplorer
    With oIE
        .Visible = False
        .Navigate strURL
    End With
    Do While oIE.Busy = True Or oIE.readyState <> 4
        DoEvents
    Loop
    Set oHDoc = oIE.Document
    For i = 1 To UBound(y)
 
    If y(i, 2) = "" Then
    x = x + 1
        valTrh = CStr(Format(y(i, 1), " dd.mm.yyyy"))
        If valTrh = "" Then Exit For
        oHDoc.getElementById("bultenKriterleriForm:j_idt30_input").Value = valTrh
        oHDoc.getElementById("bultenKriterleriForm:j_idt32").Click
        Do While oIE.Busy = True Or oIE.readyState <> 4 Or oIE.readyState <> READYSTATE_COMPLETE
            DoEvents
        Loop
        Application.Wait (Now + TimeValue("0:00:02"))
      
      
           With oHDoc.getElementsByTagName("table")(5)
      
    
    
           y(i, 2) = CDbl(Evaluate(.Rows(3).Cells(1).innerText))
           If y(i, 2) = "" Then z = z + 1
           End With
        End If
    Next i
        If x > 0 Then
      Cells(3, "B").Resize(UBound(y), 2) = y
      If z > 0 Then MsgBox z & " Adet boş Akaryakıt fiyatları bulunamamıştır", vbInformation, "ExcelCozum.com"
      GoTo 0
      Else
      MsgBox "Boş Akaryakıt fiyatları bulunamamıştır", vbInformation, "ExcelCozum.com"
      GoTo 0
      End If
    MsgBox "İşlem tamam.", vbInformation, "ExcelCozum.com"
0:
    oIE.Quit
    Application.ScreenUpdating = True
    Application.EnableEvents = True
    Application.Calculation = xlCalculationAutomatic
    Application.DisplayAlerts = True
    oIE.Quit
    Set oIE = Nothing
    Set oHDoc = Nothing
    Set xlSht = Nothing
End Sub
Genişletmek için tıkla...
 
Olumlu oy 0 Negatif oyla
Durum
Konu Çözümlendiği İçin Kapatılmıştır.
Geri
Üst