Excel Forum
ALTIN ÜYELİK Hakkında Bilgi


Geri Git   Excel Forum > EXCEL-Soruları > Diğer Excel Soruları
Atatürk
Şifremi Unuttum

DUYURU SİSTEMİ / REKLAM PANOSU

Diğer Excel Soruları Yukarıdaki başlıklara uymayan Excel sorularınızı bu bölüme gönderebilirsiniz.
Dosya ekleyebilirsiniz

Özel Arama


Yanıtla
 
Paylaş Konu Araçları Görünüm Modları
Eski 18-11-2017, 09:26   #1
leonadies
Altın Üye
 
leonadies kullanıcısının avatarı
 
Giriş: 12/02/2015
Şehir: Ankara
Mesaj: 144
Excel Vers. ve Dili:
Excel 2016 TR
Varsayılan Web-Excel Bağlantı Özel

Ü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/
Eklenmiş Resimler
Dosya Türü: jpg Resim.jpg (332.6 KB, 12 Görüntülenme)

Bu mesaj en son " 18-11-2017 " tarihinde saat 10:06 itibariyle leonadies tarafından düzenlenmiştir....
leonadies Çevrimdışı   Alıntı Yaparak Cevapla
Eski 18-11-2017, 19:49   #2
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,512
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

Alternatif olarak bu kodu bir dene

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Private Declare Function ShowWindow Lib "user32" (ByVal hWnd As Long, ByVal nCmdShow As Long) As Long

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
ShowWindow IE.hWnd, 6
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
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 18-11-2017, 21:02   #3
leonadies
Altın Üye
 
leonadies kullanıcısının avatarı
 
Giriş: 12/02/2015
Şehir: Ankara
Mesaj: 144
Excel Vers. ve Dili:
Excel 2016 TR
Varsayılan

Üstad eline sağlık, makro işlerinde giriş seviyesindeyim aldığım hatayı ekledim
Eklenmiş Resimler
Dosya Türü: jpg Resim 2.jpg (292.7 KB, 7 Görüntülenme)
leonadies Çevrimdışı   Alıntı Yaparak Cevapla
Eski 18-11-2017, 21:16   #4
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,512
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

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

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
#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


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
ShowWindow IE.hWnd, 6
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
__________________
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 18-11-2017, 21:21   #5
leonadies
Altın Üye
 
leonadies kullanıcısının avatarı
 
Giriş: 12/02/2015
Şehir: Ankara
Mesaj: 144
Excel Vers. ve Dili:
Excel 2016 TR
Varsayılan

kırmızıları sildim ancak dolar olarak geliyor yine.
Dosyayı Ekledim
Eklenmiş Dosyalar
Dosya Türü: xlsm Sorgu.xlsm (19.1 KB, 6 Görüntülenme)
leonadies Çevrimdışı   Alıntı Yaparak Cevapla
Eski 18-11-2017, 21:26   #6
leonadies
Altın Üye
 
leonadies kullanıcısının avatarı
 
Giriş: 12/02/2015
Şehir: Ankara
Mesaj: 144
Excel Vers. ve Dili:
Excel 2016 TR
Varsayılan

Birde bağlantıyı bazen boş getiriyor. Bir kaç tıklama yaparsan üstad anlarsın.
leonadies Çevrimdışı   Alıntı Yaparak Cevapla
Eski 19-11-2017, 18:50   #7
leonadies
Altın Üye
 
leonadies kullanıcısının avatarı
 
Giriş: 12/02/2015
Şehir: Ankara
Mesaj: 144
Excel Vers. ve Dili:
Excel 2016 TR
Varsayılan

ÜStad formülü düzeltebilecek miyiz?
leonadies Çevrimdışı   Alıntı Yaparak Cevapla
Eski 20-11-2017, 07:50   #8
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,512
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

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





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 20-11-2017, 13:44   #9
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,512
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

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

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Private Sub deneme()

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
'ShowWindow IE.hWnd, 3

.Width = 500
.Height = 500
.Left = 200

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
opt.Selected = (opt.Text = "TRY" Or opt.Text = "TRY")
If opt.innertext = "TRY" Then
Application.Wait (Now + TimeValue("00:00:02"))
End If
Next

bt.innertext = "TRY"
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 = "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
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Eski 20-11-2017, 15:45   #10
halit3
Uzman
 
halit3 kullanıcısının avatarı
 
Giriş: 18/01/2008
Mesaj: 10,512
Excel Vers. ve Dili:
2003 excel türkçe
Varsayılan

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

Kod: (Rahat kopyalayabilmeniz için tüm kodu seçmenizi sağlar)
Sub deneme1()

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 = 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
__________________





Forum Kuralları
halit3 Çevrimdışı   Alıntı Yaparak Cevapla
Yanıtla


Konu Araçları
Görünüm Modları

Gönderme Kuralları
You may not post new threads
You may not post replies
You may not post attachments
You may not edit your posts

BB code is Açık
SimgelerAçık
[IMG] kodu Açık
HTML kodu Kapalı


Saat 18:38


Bu forum Elit NET - www.elitnet.com.tr tarafından sunulmaktadır.

Excel Eğitimi - Mobil Uygulama - Çorlu - Çorlu Web Tasarım -- Beylikdüzü mali müşavir - Lingerie - Dyeing Machine - Karton Bardak- Çorlu Özel Eğitim- Site Yönetimi- Pronet Tekirdağ- Çorlu Kamera- Pronet Edirne- Pronet Kırklareli- Pronet Çerkezköy- Pronet Çorlu- Pronet Lüleburgaz- Pronet Keşan- Çorlu Araç Takip- Çorlu Su Arıtma- Gebze Emlak- Bakır Sülfat- Rampa- Rotary- Çorlu İnternet Sitesi- youngblood- Çorlu Sürücü Kursu- Çorlu Sandviç Panel- Şişli Avukat- Korona Test Kalemi- Çorlu Vinç- Çorlu Pimapen Tamiri- Çorlu Çelik Konstruksiyon- Çorlu Dans- Edirne Serbest Muhasebeci- Çorlu Etüt- İstanbul Botanik- Çorlu Sigorta-
Powered by vBulletin Version 3.7.2
Copyright ©2000 - 2017, Jelsoft Enterprises Ltd.
Advertisement System V2.6 By   Branden