Web-Excel Bağlantı Özel

[leonadies]

Üstadlar Merhaba çok çeşitli sitelere excel-web bağlantılarını kolaylıkla yapabiliyorum. Mesela döviz kuru bağlantısı vb.

Ancak Bu sitedeki bir filtreleme methodu nedeni ile verileri Türk Lirası Olarak alamıyorum. Yağtığım her bağlantı USD olarak geliyor. Aklınıza hemen ekstra kur bağlantısı yap çarp gelebilir ancak bu şekilde olması işime yaramıyor.

Benim Bu sitedeki verileri Ekli Resimde çizdiğim şekildeki bilgiler haliyle TRY filresi ile almam gerekiyor. Karışık gelebilir. Siteye veya ekli resmime tıklarsanız ne demek istediğim anlaşılır sanırım.

https://www.bitbaba.xyz/bitcoin-borsalari-takip-araci/

 

[halit3]

Alternatif olarak bu kodu bir dene

[COLOR="Red"]Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long[/COLOR]

Sub veri20()
Dim URL As String
Dim IE As Object
Range("A1:F100").ClearContents

URL = "https://www.bitbaba.xyz/bitcoin-borsalari-takip-araci/"
Set IE = CreateObject("InternetExplorer.Application")
sat = 1

With IE
.Navigate URL
.Visible = 1
[COLOR="red"]ShowWindow IE.hWnd, 6[/COLOR]
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop

On Error Resume Next

Set tbl = IE.Document.getElementsByTagName("table").Item()

For j = 0 To tbl.Rows(0).Cells.Length - 1
Cells(sat, j + 1) = tbl.Rows(0).Cells(j).innerText
Next
sat = sat + 1

For i = 1 To tbl.Rows.Length - 1
If tbl.Rows(i).Cells(1).innerText = [COLOR="Red"]"TRY"[/COLOR] Then
For j = 0 To tbl.Rows(i).Cells.Length - 1
If j <= 1 Then
Cells(sat, j + 1) = Replace(tbl.Rows(i).Cells(j).innerText, ".", "")
Else
Cells(sat, j + 1) = Replace(tbl.Rows(i).Cells(j).innerText, ".", "") * 1
End If
Next
sat = sat + 1
End If
Next

IE.Quit: Set IE = Nothing
End With

MsgBox ("Bitti  ")
End Sub

 

[leonadies]

Üstad eline sağlık, makro işlerinde giriş seviyesindeyim aldığım hatayı ekledim

 

[halit3]

Bu kodu bir dene eğer olmaz ise kırmızı bölümleri sil

[COLOR="Red"]#If Win64 Then
Private Declare PtrSafe Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
#Else
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long
#End If
[/COLOR]

Sub veri20()
Dim URL As String
Dim IE As Object
Range("A1:F100").ClearContents

URL = "https://www.bitbaba.xyz/bitcoin-borsalari-takip-araci/"
Set IE = CreateObject("InternetExplorer.Application")
sat = 1

With IE
.Navigate URL
.Visible = 1
[COLOR="red"]ShowWindow IE.hWnd, 6[/COLOR]
Do Until IE.ReadyState = 4: DoEvents: Loop
Do While IE.Busy: DoEvents: Loop

On Error Resume Next

Set tbl = IE.Document.getElementsByTagName("table").Item()

For j = 0 To tbl.Rows(0).Cells.Length - 1
Cells(sat, j + 1) = tbl.Rows(0).Cells(j).innerText
Next
sat = sat + 1

For i = 1 To tbl.Rows.Length - 1
If tbl.Rows(i).Cells(1).innerText = "TRY" Then
For j = 0 To tbl.Rows(i).Cells.Length - 1
If j <= 1 Then
Cells(sat, j + 1) = Replace(tbl.Rows(i).Cells(j).innerText, ".", "")
Else
Cells(sat, j + 1) = Replace(tbl.Rows(i).Cells(j).innerText, ".", "") * 1
End If
Next
sat = sat + 1
End If
Next

IE.Quit: Set IE = Nothing
End With

MsgBox ("Bitti  ")
End Sub
__________________

 

[leonadies]

kırmızıları sildim ancak dolar olarak geliyor yine.
Dosyayı Ekledim

 

[leonadies]

Birde bağlantıyı bazen boş getiriyor. Bir kaç tıklama yaparsan üstad anlarsın.

 

[leonadies]

ÜStad formülü düzeltebilecek miyiz?

 

[halit3]

O bölüme bende erişemiyorum araştırıyorum belkide boyumuzu aşıyor bu konu

 

[halit3]

Bu kodu birde işlem bitene kadar bilgisayarına dokunma

Sub deneme()

KUR = "TRY"
Dim URL As String
Dim ie As Object

Range("A1:F100").ClearContents
URL = "https://www.bitbaba.xyz/bitcoin-borsalari-takip-araci/"
Set ie = CreateObject("InternetExplorer.Application")
sat = 1

With ie
.Navigate URL
.Visible = 1
.Width = 50
.Height = 50
.Left = 20
.Top = 0

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


Set optCollection = ie.document.getElementsByTagName("SELECT")(0).getElementsByTagName("option") 'btn-group bootstrap-select") '.getElementsByTagName("options")
sat1 = 0
For Each opt In optCollection
If opt.Text = KUR Then
opt.Selected = True
opt.Click
Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop
GoTo atla1
End If
Next

atla1:

Application.Wait (Now + TimeValue("00:00:05"))

Set tbl = ie.document.getElementsByTagName("table").Item()
For j = 0 To tbl.Rows(0).Cells.Length - 1
Cells(sat, j + 1) = tbl.Rows(0).Cells(j).innerText
Next
sat = sat + 1
For i = 1 To tbl.Rows.Length - 1
If tbl.Rows(i).Cells(1).innerText = KUR Then
For j = 0 To tbl.Rows(i).Cells.Length - 1
If j <= 1 Then
Cells(sat, j + 1) = Replace(tbl.Rows(i).Cells(j).innerText, ".", "")
Else
Cells(sat, j + 1) = Replace(tbl.Rows(i).Cells(j).innerText, ".", "") * 1
End If
Next
sat = sat + 1
End If
Next

ie.Quit: Set ie = Nothing
End With

MsgBox ("Bitti  ")
End Sub

 

[halit3]

Bu koda farklı kırmızı yere aranan kuru yazıyorsunuz.

Sub deneme1()

KUR = "[COLOR="Red"]TRY[/COLOR]"

Dim URL As String
Dim ie As Object
Range("A1:F100").ClearContents

URL = "https://www.bitbaba.xyz/bitcoin-borsalari-takip-araci/"
Set ie = CreateObject("InternetExplorer.Application")
sat = 1

With ie
.Navigate URL
.Visible = 1

.Width = 500
.Height = 900
.Left = 250
.Top = 0
Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop
Application.Wait (Now + TimeValue("00:00:05"))

'On Error Resume Next

Set divs = ie.document.GetElementsByTagName("div")
For Each divi In divs
If divi.ID = "bittable" Then
Set botoes = ie.document.GetElementsByTagName("BUTTON")

For Each bt In botoes
If bt.ClassName = "btn dropdown-toggle btn-default" Then

Dim optCollection
Set optCollection = ie.document.GetElementsByTagName("SELECT")(0).Options

For Each opt In optCollection

If opt.Text = KUR Then
opt.Selected = (opt.Text = KUR Or opt.Text = KUR)
Application.Wait (Now + TimeValue("00:00:04"))
End If
Next

bt.innertext = KUR
Application.Wait (Now + TimeValue("00:00:02"))

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

GoTo atla1
Exit For
End If
Next bt
End If
Next divi

atla1:

Set tbl = ie.document.GetElementsByTagName("table").Item()

For j = 0 To tbl.Rows(0).Cells.Length - 1
Cells(sat, j + 1) = tbl.Rows(0).Cells(j).innertext
Next
sat = sat + 1

For i = 1 To tbl.Rows.Length - 1
'If tbl.Rows(i).Cells(1).innertext = KUR Then
For j = 0 To tbl.Rows(i).Cells.Length - 1
If j <= 1 Then
Cells(sat, j + 1) = Replace(tbl.Rows(i).Cells(j).innertext, ".", "")
Else
Cells(sat, j + 1) = Replace(tbl.Rows(i).Cells(j).innertext, ".", "") * 1
End If
Next
sat = sat + 1
'End If
Next
ie.Quit: Set ie = Nothing
End With

MsgBox ("Bitti  ")
End Sub

 

[leonadies]

İki Şekilde de denedim ama olmuyor. Webi açıyor sadece oakdar.Ekteki hatayı veriyor.

 

[halit3]

görsel video

Görsel video yükleniyor ara ara indirmeyi demeyin

Sub deneme3()

KUR = "TRY"
Dim URL As String
Dim ie As Object

Range("A1:F100").ClearContents
URL = "https://www.bitbaba.xyz/bitcoin-borsalari-takip-araci/"
Set ie = CreateObject("InternetExplorer.Application")
sat = 1

With ie
.Navigate URL
.Visible = 1
.Width = 50
.Height = 50
.Left = 20
.Top = 0

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

Set optCollection = ie.document.getElementsByTagName("SELECT")(0).getElementsByTagName("option") 'btn-group bootstrap-select") '.getElementsByTagName("options")
sat1 = 0
For Each opt In optCollection
If opt.Text = KUR Then
opt.Selected = True
opt.Click
Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop
GoTo atla1
End If
Next

atla1:

Application.Wait (Now + TimeValue("00:00:05"))

Set tbl = ie.document.getElementsByTagName("table").Item()
For j = 0 To tbl.Rows(0).Cells.Length - 1
Cells(sat, j + 1) = tbl.Rows(0).Cells(j).innerText
Next
sat = sat + 1
For i = 1 To tbl.Rows.Length - 1
If tbl.Rows(i).Cells(1).innerText = KUR Then
For j = 0 To tbl.Rows(i).Cells.Length - 1
If j <= 1 Then
Cells(sat, j + 1) = Replace(tbl.Rows(i).Cells(j).innerText, ".", "")
Else
Cells(sat, j + 1) = Replace(tbl.Rows(i).Cells(j).innerText, ".", "") * 1
End If
Next
sat = sat + 1
End If
Next

ie.Quit: Set ie = Nothing
End With

MsgBox ("Bitti  ")
End Sub

 

[leonadies]

Olmuş üstadım teşekkür ederim. Fark ettim ki iş yerindeki PC debu hatayı alıyorum. Evdeki PC de sorun yok.

Birde buna 30 saniyede bir yenile makrosu yazdık mı işlem tamamdır. Onu da az bucuk araştırmayla çözecek gibiyim. Çok teşekkür ederim gerçekten

 

[halit3]

Bu kod daha kısa

Sub deneme2()

KUR = "TRY"

Dim URL As String
Dim ie As Object
Range("A1:F100").ClearContents

URL = "https://www.bitbaba.xyz/bitcoin-borsalari-takip-araci/"
Set ie = CreateObject("InternetExplorer.Application")
sat = 1

With ie
.Navigate URL
.Visible = 1

.Width = 500
.Height = 850
.Left = 250
.Top = 0
Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop
Application.Wait (Now + TimeValue("00:00:05"))

'On Error Resume Next

For Each element In ie.document.getElementsByTagName("select")(0).getElementsByTagName("option")
'MsgBox element.innerText

If element.innerText = KUR Then
element.Selected = True

Do Until ie.ReadyState = 4: DoEvents: Loop
Do While ie.Busy: DoEvents: Loop
Application.Wait (Now + TimeValue("00:00:04"))
Exit For
Else
End If
Next


Set tbl = ie.document.getElementsByTagName("table").Item()

For j = 0 To tbl.Rows(0).Cells.Length - 1
Cells(sat, j + 1) = tbl.Rows(0).Cells(j).innerText
Next
sat = sat + 1

For i = 1 To tbl.Rows.Length - 1
'If tbl.Rows(i).Cells(1).innertext = KUR Then
For j = 0 To tbl.Rows(i).Cells.Length - 1
If j <= 1 Then
Cells(sat, j + 1) = Replace(tbl.Rows(i).Cells(j).innerText, ".", "")
Else
Cells(sat, j + 1) = Replace(tbl.Rows(i).Cells(j).innerText, ".", "") * 1
End If
Next
sat = sat + 1
'End If
Next



ie.Quit: Set ie = Nothing
End With

MsgBox ("Bitti  ")
End Sub