ekte örnek dosya var birçok örnek var ama hepsi iki tarih arası sorgulama yapıyor ve bi butona atanmış olarak çalışıyor ben o şekilde değilde hücreye ilgili tarihi girdiğimde bu tarihe ait kurun gelmesini istiyorum
-
DİKKAT DOSYA İndirmek/Yüklemek için ÜCRETLİ ALTIN ÜYELİK Gereklidir!
Altın Üyelik Hakkında Bilgi
döviz kuru
- Konbuyu başlatan masuk500
- Başlangıç tarihi
- Katılım
- 15 Mart 2005
- Mesajlar
- 43,812
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Selamlar,
Ekteki örnek dosyayı icelermisiniz.
Kullanılan kod; (İlgili sayfanın kod bölümüne uygulayınız.)
Siz A sütunundaki hücrelere tarih girdikçe;
B sütununa uygulanan kur tarihi
C-D sütunlarına Euro ve Dolar (Alış) kurları otomatik gelecektir.
Ayrıca örnek dosyaya RESMİ TATİL sayfası eklenmiştir. Bu sayfa sorgulama yaptığınız tarihin resmi tatile denk gelip gelmediğini kontrol için eklenmiştir.
A sütununa haftasonlarını ve resmi tatilleri belirginleştirmek için koşullu biçimlendirme uygulanmıştır.
Ekteki örnek dosyayı icelermisiniz.
Kullanılan kod; (İlgili sayfanın kod bölümüne uygulayınız.)
Siz A sütunundaki hücrelere tarih girdikçe;
B sütununa uygulanan kur tarihi
C-D sütunlarına Euro ve Dolar (Alış) kurları otomatik gelecektir.
Ayrıca örnek dosyaya RESMİ TATİL sayfası eklenmiştir. Bu sayfa sorgulama yaptığınız tarihin resmi tatile denk gelip gelmediğini kontrol için eklenmiştir.
A sütununa haftasonlarını ve resmi tatilleri belirginleştirmek için koşullu biçimlendirme uygulanmıştır.
Kod:
Option Explicit
Private Sub Worksheet_Change(ByVal Target As Range)
Dim S1 As Worksheet, S2 As Worksheet, SK As Worksheet
Dim BUL As Range
Dim TARİH As Date, YENİ_TARİH As Date
Dim SAYFA_ADI As String
Dim KONTROL As Byte
Dim ONAY As String
Dim URL_LINK As String
Dim EURO_BUL As Range, EURO_SATIR As Long, SÜTUN As Integer, EURO_SÜTUN As Byte
Dim USD_BUL As Range, USD_SATIR As Long, USD_SÜTUN As Byte, SAY As Byte
If Intersect(Target, [A2:A65536]) Is Nothing Then Exit Sub
If Target.Rows.Count = 1 And Target.Count > 1 Then Exit Sub
If Target.Rows.Count > 1 And WorksheetFunction.CountIf(Range(Selection.Resize(Selection.Rows.Count, 1).Address), "") = Target.Rows.Count Then
Range("B" & Selection.Row, "D" & Selection.Row + Selection.Rows.Count - 1).ClearContents
Exit Sub
End If
If IsDate(Target) = False And Target <> "" Then
Range("B" & Target.Row, "D" & Target.Row).ClearContents
MsgBox "Lütfen tarih giriniz !", vbExclamation, "Dikkat !"
Target.Select
Exit Sub
End If
If Target = "" Then
Range("B" & Target.Row, "D" & Target.Row).ClearContents
Target.Select
Exit Sub
End If
If Not IsNumeric(CLng(Target)) Then
MsgBox "Hatalı tarih girişi !" & vbCrLf & _
"Lütfen girdiğiniz tarihi kontrol ediniz !", vbExclamation, "Dikkat !"
Target = Empty
Target.Select
Exit Sub
End If
If Target > Date Then
MsgBox "Bugünden büyük bir tarihi sorgulayamazsınız !" & vbCrLf & _
"Lütfen girdiğiniz tarihi kontrol ediniz !", vbExclamation, "Dikkat !"
Target.Select
Exit Sub
End If
Set S1 = Sheets("KUR_LİSTESİ")
Set S2 = Sheets("RESMİ_TATİLLER")
TARİH = Target
SAYFA_ADI = "KURLAR"
Application.ScreenUpdating = False
Target.Offset(0, 1).ClearContents
Target.Offset(0, 2).ClearContents
Target.Offset(0, 3).ClearContents
On Error Resume Next
Application.DisplayAlerts = False
Sheets("KURLAR").Delete
Application.DisplayAlerts = True
Sheets.Add , After:=Sheets(Worksheets.Count)
ActiveSheet.Name = SAYFA_ADI
Set SK = Sheets(SAYFA_ADI)
S1.Select
With Application
.DecimalSeparator = "."
.ThousandsSeparator = ","
.UseSystemSeparators = False
End With
KONTROL = Weekday(TARİH, vbMonday)
YENİ_TARİH = IIf(KONTROL > 5, TARİH - (KONTROL - 5), TARİH)
Başla:
Set BUL = S2.Range("C:C").Find(TARİH, LookAt:=xlWhole)
If (Weekday(TARİH, vbMonday) = 6 Or Weekday(TARİH, vbMonday) = 7) And Not BUL Is Nothing Then
YENİ_TARİH = YENİ_TARİH - 1
MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir. Aynı zamanda resmi tatildir." _
& vbCrLf & vbCrLf & S2.Range("A" & BUL.Row) & vbCrLf & S2.Range("B" & BUL.Row) & vbCrLf & S2.Range("C" & BUL.Row) & vbCrLf & S2.Range("D" & BUL.Row) _
& vbCrLf & vbCrLf & YENİ_TARİH & " gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
ElseIf Weekday(TARİH, vbMonday) < 6 And Not BUL Is Nothing Then
YENİ_TARİH = YENİ_TARİH - 1
MsgBox "Sorgulamak istediğiniz tarih resmi tatildir." _
& vbCrLf & vbCrLf & S2.Range("A" & BUL.Row) & vbCrLf & S2.Range("B" & BUL.Row) & vbCrLf & S2.Range("C" & BUL.Row) & vbCrLf & S2.Range("D" & BUL.Row) _
& vbCrLf & vbCrLf & YENİ_TARİH & " gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
ElseIf Weekday(TARİH, vbMonday) = 6 Or Weekday(TARİH, vbMonday) = 7 Then
YENİ_TARİH = YENİ_TARİH - 1
MsgBox "Sorgulamak istediğiniz tarih haftasonuna ait bir tarihtir." _
& vbCrLf & vbCrLf & YENİ_TARİH & " gününe ait kur bilgileri alınacaktır.", vbExclamation, "Dikkat !"
End If
If WorksheetFunction.CountIf(S2.Range("C:C"), YENİ_TARİH) > 0 Or _
Weekday(YENİ_TARİH, vbMonday) = 6 Or Weekday(YENİ_TARİH, vbMonday) = 7 Then
TARİH = YENİ_TARİH
GoTo Başla
End If
If Time >= "15:30:00" And YENİ_TARİH = Date And Weekday(YENİ_TARİH, vbMonday) < 6 Then
ONAY = MsgBox("Şuanda Saat " & TimeSerial(Hour(Now()), Minute(Now()), Second(Now())) _
& vbCrLf & vbCrLf & "Dün yayımlanmış resmi kurlar alınacaktır !" _
& vbCrLf & "Devam etmek istiyor musunuz ?", vbExclamation + vbYesNo, "Dikkat !")
If ONAY = vbYes Then
YENİ_TARİH = IIf(YENİ_TARİH = TARİH, YENİ_TARİH - 1, YENİ_TARİH)
End If
End If
Application.EnableEvents = False
Target.Offset(0, 1) = YENİ_TARİH
Application.EnableEvents = True
On Error GoTo Hata
URL_LINK = "URL;http://www.tcmb.gov.tr/kurlar/" & Year(YENİ_TARİH) & Format(Month(YENİ_TARİH), "00") & "/" & Format(Day(YENİ_TARİH), "00") & Format(Month(YENİ_TARİH), "00") & Year(YENİ_TARİH) & ".html"
With SK.QueryTables.Add(Connection:=URL_LINK, Destination:=SK.Range("A1"))
.Name = YENİ_TARİH
.FieldNames = True
.RowNumbers = False
.FillAdjacentFormulas = False
.PreserveFormatting = True
.RefreshOnFileOpen = False
.BackgroundQuery = True
.RefreshStyle = xlOverwriteCells
.SavePassword = False
.SaveData = True
.AdjustColumnWidth = True
.RefreshPeriod = 0
.WebSelectionType = xlAllTables
.WebFormatting = xlWebFormattingNone
.WebPreFormattedTextToColumns = True
.WebConsecutiveDelimitersAsOne = True
.WebSingleBlockTextImport = False
.WebDisableDateRecognition = False
.WebDisableRedirections = False
.Refresh BackgroundQuery:=False
End With
If SK.[A1] <> "" Then
Set EURO_BUL = SK.[A:A].Find(What:="EUR", LookAt:=xlPart)
If Not EURO_BUL Is Nothing Then
EURO_SATIR = EURO_BUL.Row
For SÜTUN = 2 To 256
SAY = WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "DÖVİZ") + WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "ALIŞ")
If IsNumeric(Right(SK.Cells(EURO_SATIR, SÜTUN), 1)) = True And SAY > 0 Then
EURO_SÜTUN = SÜTUN
Exit For
End If
Next
End If
Set USD_BUL = SK.[A:A].Find(What:="USD", LookAt:=xlPart)
If Not USD_BUL Is Nothing Then
USD_SATIR = USD_BUL.Row
For SÜTUN = 2 To 256
SAY = WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "DÖVİZ") + WorksheetFunction.CountIf(SK.Range(SK.Cells(1, SÜTUN), SK.Cells(65536, SÜTUN)), "ALIŞ")
If IsNumeric(Right(SK.Cells(USD_SATIR, SÜTUN), 1)) = True And SAY > 0 Then
USD_SÜTUN = SÜTUN
Exit For
End If
Next
End If
S1.Cells(Target.Row, 3) = SK.Cells(EURO_SATIR, EURO_SÜTUN)
S1.Cells(Target.Row, 4) = SK.Cells(USD_SATIR, USD_SÜTUN)
End If
Application.DisplayAlerts = False
SK.Delete
Application.DisplayAlerts = True
With Application
.DecimalSeparator = ","
.ThousandsSeparator = "."
.UseSystemSeparators = False
End With
Set S1 = Nothing
Set S2 = Nothing
Set SK = Nothing
Application.ScreenUpdating = True
Exit Sub
Hata:
S1.Cells(Target.Row, 3) = "Hata !"
S1.Cells(Target.Row, 4) = "Hata !"
With Application
.DecimalSeparator = ","
.ThousandsSeparator = "."
.UseSystemSeparators = False
End With
Application.DisplayAlerts = False
SK.Delete
Application.DisplayAlerts = True
Set S1 = Nothing
Set S2 = Nothing
Set SK = Nothing
Application.ScreenUpdating = True
MsgBox "İnternet bağlantısı şu anda kurulamıyor." _
& vbCrLf & "Lütfen daha sonra tekrar deneyiniz.", vbCritical, "Dikkat !"
End Sub- Katılım
- 15 Mart 2005
- Mesajlar
- 43,812
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Selamlar,
Üstteki mesajımdaki dosyada ve kodda düzenlemeler yaptım. İncelermisiniz.
Üstteki mesajımdaki dosyada ve kodda düzenlemeler yaptım. İncelermisiniz.
- Katılım
- 15 Mart 2005
- Mesajlar
- 43,812
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
Selamlar,
#3 nolu mesajdaki dosyayı ve kodları güncelledim. İncelermisiniz.
Bazı tarihlerde TCMB sitesinde ilgili sayfa görüntülenemediği için hata vermektedir. Bu gibi durumlarda hata veren tarihe ait kuru ilgili siteye girip elle düzeltmelisiniz.
Ayıca resmi tatilleri gösteren bir sayfa ekledim. Bu sayfadaki veriler 2006-2015 yıllarını kapsamaktadır. Eğer daha eski yıllara ait kur bilgisi sorgularsanız ve bu resmi tatile denk geliyorsa doğru sonuç alamayacaksınız. Bunun için sorgulama yaptığınız yıla ait resmi tatilleri bu sayfaya aynı formatta eklemeniz gerekecektir. Bu sayfanın görünmesini istemiyorsanız gizleyebilirsiniz.
Denemelerinizi yapıp hata veren bölümleri belirtirseniz düzeltmeye çalışırım.
#3 nolu mesajdaki dosyayı ve kodları güncelledim. İncelermisiniz.
Bazı tarihlerde TCMB sitesinde ilgili sayfa görüntülenemediği için hata vermektedir. Bu gibi durumlarda hata veren tarihe ait kuru ilgili siteye girip elle düzeltmelisiniz.
Ayıca resmi tatilleri gösteren bir sayfa ekledim. Bu sayfadaki veriler 2006-2015 yıllarını kapsamaktadır. Eğer daha eski yıllara ait kur bilgisi sorgularsanız ve bu resmi tatile denk geliyorsa doğru sonuç alamayacaksınız. Bunun için sorgulama yaptığınız yıla ait resmi tatilleri bu sayfaya aynı formatta eklemeniz gerekecektir. Bu sayfanın görünmesini istemiyorsanız gizleyebilirsiniz.
Denemelerinizi yapıp hata veren bölümleri belirtirseniz düzeltmeye çalışırım.
- Katılım
- 28 Nisan 2009
- Mesajlar
- 355
- Excel Vers. ve Dili
- 2003 tr
Hocam hayırlı günler bana iki tarih arasındaki dolar kuru lazım sayfada bazı yerlerde var ama doğru bir şekilde çalışmıyor. Benim istediğim iki tarihi girdiğin zaman arasındaki tarihlerin dolar kurunu karşısına versin
Korhan hocanın yaptığı tabloya başka sayfadan veri alıp mesela satış sayfası f16 dan veri alıp
SATIŞ!F16 yaptığımızda orda değişiklik oluyor ama veri almıyor bu sefer bunu yapabilirmiyiz gerisini
düşey ara yaparak aktarabilirim
saygılarla
SATIŞ!F16 yaptığımızda orda değişiklik oluyor ama veri almıyor bu sefer bunu yapabilirmiyiz gerisini
düşey ara yaparak aktarabilirim
saygılarla
merhaba arkadaşlar
TCMB de olan değişiklikten dolayı yukarıdaki kodlar çalışmıyor yardımcı olabilirmisiniz
- Katılım
- 15 Mart 2005
- Mesajlar
- 43,812
- Excel Vers. ve Dili
- Microsoft 365 Tr-En 64 Bit
sayın korhan ayhan
19.mesajdaki çalışmanızda günlük kurlar geliyor ama istediğim tarihlerdeki değil
şöyleki 01/10/2014 tarihli kuru çekmek istediğimde 30/09/2014 tarihli kuru görmek istiyorum
ayrıca cumartesi pazar ve pazartesi veya tatil günlerine ait kur değerlerinin tatilden önceki güne ait kurun gelmesi lazım
örneğin 06/09/2014 cumartesi günü kuru çekildiğinde 05/09/2014 gününe ait kur gelmesi gerekirken 04/09/2014 gününün kuru geliyor
19.mesajdaki çalışmanızda günlük kurlar geliyor ama istediğim tarihlerdeki değil
şöyleki 01/10/2014 tarihli kuru çekmek istediğimde 30/09/2014 tarihli kuru görmek istiyorum
ayrıca cumartesi pazar ve pazartesi veya tatil günlerine ait kur değerlerinin tatilden önceki güne ait kurun gelmesi lazım
örneğin 06/09/2014 cumartesi günü kuru çekildiğinde 05/09/2014 gününe ait kur gelmesi gerekirken 04/09/2014 gününün kuru geliyor