döviz kuru alma (farklı bir kayıt formunda)

[stuck]

benim euro kurunu otomatik olarak almam gerekiyor fakat gün; a, ay; b ve yıl; c sütunlarında bulunuyor. bunun için bu sütunları eski ve yeni girilecek kayıtlar için farklı bir sütunda otomatik olarak birleştirip mi euro kurunu almam gerekiyor? yoksa farklı bir yol mevcut mudur? bir de tarih formatı 01/01/2011 şeklinde değil 1/1/2011 şeklinde kayıt altına alınıyor. bu da ayrıca bir işlem gerektirir mi?

 

[f_alkan]

aşağıdaki kodu çalıştırın
iyi çalışmalar dilerim.
Sub SORGULA()
Dim SR As Worksheet, Sayfa_Adı As String, SK As Worksheet
Dim X As Date, KONTROL As Byte, Y As Date, Z As Date
Dim URL1 As String, SATIR As Long, SAY As Byte
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

Application.ScreenUpdating = False
Set SR = Sheets("ARALIK")
SR.Select
If [B1] = "" Then MsgBox "Lütfen ilk tarihi giriniz !", vbExclamation, "Dikkat !": [B1].Select: Exit Sub
If [B2] = "" Then MsgBox "Lütfen son tarihi giriniz !", vbExclamation, "Dikkat !": [B2].Select: Exit Sub
If [B2] < [B1] Then
MsgBox "Son tarih ilk tarihten küçük olamaz !" _
& Chr(10) & Chr(10) & "Lütfen girdiğiniz bilgileri kontrol ediniz.", vbCritical, "Dikkat !"
[B2].ClearContents
[B2].Select
Exit Sub
End If

[A6:I65536].ClearContents

On Error Resume Next
Application.DisplayAlerts = False
Sheets("KURLAR").Delete
Application.DisplayAlerts = True

Sheets.Add
Sayfa_Adı = "KURLAR"
ActiveSheet.Name = Sayfa_Adı
Set SK = Sheets(Sayfa_Adı)

'With Application
'.DecimalSeparator = "."
'.ThousandsSeparator = ","
'.UseSystemSeparators = False
'End With

SR.Select
BEKLEME.Show
Application.Wait (Now + TimeValue("0:00:01"))

For X = SR.[B1] - 1 To SR.[B2] - 1
If X > Date - 1 Then Exit For
KONTROL = Weekday(X, vbMonday)
If KONTROL > 5 Then
Y = X - (KONTROL - 5)
Else
Y = X
End If

On Error Resume Next

URL1 = "URL;http://www.tcmb.gov.tr/kurlar/" & Year(Y) & Format(Month(Y), "00") & "/" & Format(Day(Y), "00") & Format(Month(Y), "00") & Year(Y) & ".html"

With SK.QueryTables.Add(Connection:=URL1, Destination:=SK.Range("A1"))
.Name = Y
.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

SATIR = SR.[A65536].End(3).Row + 1
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

SR.Cells(SATIR, 1) = X + 1
SR.Cells(SATIR, 2) = IIf(Left(SK.Cells(EURO_SATIR, EURO_SÜTUN), 1) = 0, Replace(SK.Cells(EURO_SATIR, EURO_SÜTUN), ".", ",") * 1, SK.Cells(EURO_SATIR, EURO_SÜTUN) / 10000)
SR.Cells(SATIR, 3) = IIf(Left(SK.Cells(EURO_SATIR, EURO_SÜTUN + 1), 1) = 0, Replace(SK.Cells(EURO_SATIR, EURO_SÜTUN + 1), ".", ",") * 1, SK.Cells(EURO_SATIR, EURO_SÜTUN + 1) / 10000)
SR.Cells(SATIR, 4) = IIf(Left(SK.Cells(EURO_SATIR, EURO_SÜTUN + 2), 1) = 0, Replace(SK.Cells(EURO_SATIR, EURO_SÜTUN + 2), ".", ",") * 1, SK.Cells(EURO_SATIR, EURO_SÜTUN + 2) / 10000)
SR.Cells(SATIR, 5) = IIf(Left(SK.Cells(EURO_SATIR, EURO_SÜTUN + 3), 1) = 0, Replace(SK.Cells(EURO_SATIR, EURO_SÜTUN + 3), ".", ",") * 1, SK.Cells(EURO_SATIR, EURO_SÜTUN + 3) / 10000)

SR.Cells(SATIR, 6) = IIf(Left(SK.Cells(USD_SATIR, USD_SÜTUN), 1) = 0, Replace(SK.Cells(USD_SATIR, USD_SÜTUN), ".", ",") * 1, SK.Cells(USD_SATIR, USD_SÜTUN) / 10000)
SR.Cells(SATIR, 7) = IIf(Left(SK.Cells(USD_SATIR, USD_SÜTUN + 1), 1) = 0, Replace(SK.Cells(USD_SATIR, USD_SÜTUN + 1), ".", ",") * 1, SK.Cells(USD_SATIR, USD_SÜTUN + 1) / 10000)

SR.Cells(SATIR, 8) = IIf(Left(SK.Cells(USD_SATIR, USD_SÜTUN + 2), 1) = 0, Replace(SK.Cells(USD_SATIR, USD_SÜTUN + 2), ".", ",") * 1, SK.Cells(USD_SATIR, USD_SÜTUN + 2) / 10000)
SR.Cells(SATIR, 9) = IIf(Left(SK.Cells(USD_SATIR, USD_SÜTUN + 3), 1) = 0, Replace(SK.Cells(USD_SATIR, USD_SÜTUN + 3), ".", ",") * 1, SK.Cells(USD_SATIR, USD_SÜTUN + 3) / 10000)
End If

For Z = X To X - 7 Step -1
If SK.[A1] <> "" Then GoTo Devam
KONTROL = Weekday(Z, vbMonday)
If KONTROL > 5 Then
Y = Z - (KONTROL - 5)
Else
Y = Z
End If

On Error Resume Next

URL1 = "URL;http://www.tcmb.gov.tr/kurlar/" & Year(Y) & Format(Month(Y), "00") & "/" & Format(Day(Y), "00") & Format(Month(Y), "00") & Year(Y) & ".html"

With SK.QueryTables.Add(Connection:=URL1, Destination:=SK.Range("A1"))
.Name = Y
.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

SATIR = SR.[A65536].End(3).Row + 1
If SK.[A1] <> "" Then

SR.Cells(SATIR, 1) = X + 1
SR.Cells(SATIR, 2) = IIf(Left(SK.Cells(EURO_SATIR, EURO_SÜTUN), 1) = 0, Replace(SK.Cells(EURO_SATIR, EURO_SÜTUN), ".", ",") * 1, SK.Cells(EURO_SATIR, EURO_SÜTUN) / 10000)
SR.Cells(SATIR, 3) = IIf(Left(SK.Cells(EURO_SATIR, EURO_SÜTUN + 1), 1) = 0, Replace(SK.Cells(EURO_SATIR, EURO_SÜTUN + 1), ".", ",") * 1, SK.Cells(EURO_SATIR, EURO_SÜTUN + 1) / 10000)
SR.Cells(SATIR, 4) = IIf(Left(SK.Cells(EURO_SATIR, EURO_SÜTUN + 2), 1) = 0, Replace(SK.Cells(EURO_SATIR, EURO_SÜTUN + 2), ".", ",") * 1, SK.Cells(EURO_SATIR, EURO_SÜTUN + 2) / 10000)
SR.Cells(SATIR, 5) = IIf(Left(SK.Cells(EURO_SATIR, EURO_SÜTUN + 3), 1) = 0, Replace(SK.Cells(EURO_SATIR, EURO_SÜTUN + 3), ".", ",") * 1, SK.Cells(EURO_SATIR, EURO_SÜTUN + 3) / 10000)
SR.Cells(SATIR, 6) = IIf(Left(SK.Cells(USD_SATIR, USD_SÜTUN), 1) = 0, Replace(SK.Cells(USD_SATIR, USD_SÜTUN), ".", ",") * 1, SK.Cells(USD_SATIR, USD_SÜTUN + 1) / 10000)
SR.Cells(SATIR, 7) = IIf(Left(SK.Cells(USD_SATIR, USD_SÜTUN + 1), 1) = 0, Replace(SK.Cells(USD_SATIR, USD_SÜTUN + 1), ".", ",") * 1, SK.Cells(USD_SATIR, USD_SÜTUN + 1) / 10000)
SR.Cells(SATIR, 8) = IIf(Left(SK.Cells(USD_SATIR, USD_SÜTUN + 2), 1) = 0, Replace(SK.Cells(USD_SATIR, USD_SÜTUN + 2), ".", ",") * 1, SK.Cells(USD_SATIR, USD_SÜTUN + 2) / 10000)
SR.Cells(SATIR, 9) = IIf(Left(SK.Cells(USD_SATIR, USD_SÜTUN + 3), 1) = 0, Replace(SK.Cells(USD_SATIR, USD_SÜTUN + 3), ".", ",") * 1, SK.Cells(USD_SATIR, USD_SÜTUN + 3) / 10000)
End If

DoEvents
Next
Devam:
Next

Application.DisplayAlerts = False
SK.Delete
Application.DisplayAlerts = True

'With Application
'.DecimalSeparator = ","
'.ThousandsSeparator = "."
'.UseSystemSeparators = False
'End With

[A1].Select
Application.ScreenUpdating = True
Unload BEKLEME
MsgBox "Döviz sorgulama işlemi başarıyla tamamlanmıştır.", vbInformation
End Sub

Sub TCMB()
On Error GoTo Hata
Shell "C:\Program Files\Internet Explorer\IEXPLORE.EXE " & "http://www.tcmb.gov.tr", vbMaximizedFocus
Exit Sub
Hata:
MsgBox "İnternet bağlantısı şu anda kurulamıyor." _
& Chr(10) & "Lütfen daha sonra tekrar deneyiniz.", vbCritical, "Dikkat !"
End Sub

 

[stuck]

Hmmm. Şimdi muhtemelen bana Allah'ın dangalağı diyebilirsiniz ama belirtmem gereken iki şey var.
Birincisi; iş yerinde olduğum için Türkçe Excel 2007 kullanıyorum.
İkincisi; bu istemi nasıl çalıştıracağım? Daha önceden hiç makro ya da visual basicte herhangi bir komut ya da istem yazmışlığım yok. Ya da bunu sadece bir hücreye mı yapıştıracağım?
=/

 

[Korhan Ayhan]

Merhaba,

Aşağıdaki linkte bir çok örnek bulunuyor. İncelermisiniz.

http://www.excel.web.tr/f125/

 

[stuck]

evet bunlara baktım ama istediğim formatta olan bir tanesiyle karşılaşmadığım için tekrardan başlık açmak durumunda kaldım.

 

[Korhan Ayhan]

Merhaba,

Bu durumda örnek dosya eklemeniz gerekiyor.

 

[stuck]

tabiki hemen ekliyorum. J sütunundaki kurların altına ilgili tarihlerin euro kurlarının gelmesi gerekiyor.

 

[Korhan Ayhan]

Merhaba,

Ekteki örnek dosyayı incelermisiniz.

A-B-C sütunlarına tarih girişini tamamladığınızda kur bilgisi alınacaktır.

 

[stuck]

Çok teşekkür ederim. Peki döviz satış için hangi satırını değiştirmem gerekiyor bu makroda? =/

 

[stuck]

evet, tam sopalığım =(

 

[stuck]

Sanırım "Alış" ı "Satış"a çevirince hallolur gibime geldi.

 

[Korhan Ayhan]

Merhaba,

Mesajınızda "Döviz Satış" kurunu almak istediğinizi belirtmemişsiniz. Ekteki dosya "Döviz Satış" kurunu almaktadır. Denermisiniz.

A-B-C sütunlarına tarih girişini tamamladığınızda kur bilgisi alınacaktır.

 

[stuck]

çok teşekkür ederim. her şey harika olmuş. elinize sağlık. bir de excel öğrenmek için güzel bir kaynak arıyorum. iyice öğrenmek istiyorum. tavsiye edebileceğiniz bir kaynak var mıdır?

 

[Korhan Ayhan]

Merhaba,

Forumumuz sizler için iyi bir kaynatır. Dersane bölümünü inceleyerek işe koyulabilirsiniz. Bol pratik yaparak ve konuları irdeleyerek öğrendiklerinizi pekiştirebilirsiniz.

Ayrıca nettende bir çok kaynağa ulaşabilirsiniz.