imkb de metastock formatlı data

D

diskriminant

Katılım
14 Kasım 2006
Mesajlar
16
Excel Vers. ve Dili
excel 2003
http://www.imkb.gov.tr/veriler/gk/2006/11/tgk200611131.zip adresinde yayımlanan 13 kasım 2006 tarihli geçici kapanış bülteni yer almaktadır.Bu şekliyle bu veriler metastock programı tarafından tanınmamaktadır.Aşağıda verdiğim makro ile bu veriler metastock un tanıdığı formata çevrilmektedir.

Sub MetaStockSeans()

' Macro recorded 15/10/2006 by ******
'

'
Dim ToDay As String
Dim Hour As String
Dim Imkb100Volume As Currency
Dim ExchRate As Double
Dim SecVolume As String
Dim FName As String
Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Single
Dim ColNdx As Integer
Dim StartRow As Single
Dim EndRow As Single
Dim StartCol As Integer
Dim EndCol As Integer
Dim StrFlag As Integer
Dim Seans As Integer
Dim Dizin As String

ToDay = Cells(3, 2).Text
Dizin = Cells(3, 5).Text & "\" & Format(ToDay, "yyyymmdd") & "\"
For Seans = 1 To 2
Imkb100Volume = 0
ExchRate = 1
StrFlag = 0
'FName = "s" & CStr(Seans) & "tl"
'Sheets(FName).Select
'Range("A1").Select
Workbooks.Open Filename:=Dizin & Format(ToDay, "yyyymmdd") & "s" & CStr(Seans) & ".xls"

FName = Application.GetSaveAsFilename(Left(ActiveWorkbook.FullName, _
Len(ActiveWorkbook.FullName) - 4) & ".prn")

Application.ScreenUpdating = False
On Error GoTo EndMacro:
FNum = FreeFile

Range("A1").EntireRow.Insert
myFormula = "=MAX(LEN(A2:A" & ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Row & "))+1"
Range("A1").FormulaArray = myFormula
Range("A1").AutoFill Destination:=Range(Cells(1, 1), Cells(1, _
ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Column)), _
Type:=xlFillDefault


With Intersect(ActiveSheet.UsedRange, Rows("2:65536"))
'With Selection
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With

Open FName For Output Access Write As #FNum

If (Cells(StartRow, 15).Text = "1") Then
Hour = "120000"
Else
Hour = "160000"
End If

'ToDay = Cells(StartRow + 1, 2).Text
Print #FNum, "<TICKER>,<PER>,<DTYYYYMMDD>,<TIME>,<OPEN>,<HIGH>,<LOW>,<CLOSE>,<VOL>,<OPENINT>"

For RowNdx = StartRow To EndRow
WholeLine = ""
If (RowNdx < 8) Then GoTo SkipLine:

If (Cells(RowNdx, 4).Text = "") Then
GoTo SkipLine
End If

If (Cells(RowNdx, 4).Text = "KOD") Then
GoTo SkipLine
End If

If (Cells(RowNdx, 23).Value = 0) Then 'işlem olmamış tahtaları atla
GoTo SkipLine
End If

If (Cells(RowNdx, 4).Text = "XU100") Then
StrFlag = 1
SecVolume = Str(Imkb100Volume)
Else
SecVolume = "0"
End If

If (StrFlag = 1) Then 'Endeksler
WholeLine = WholeLine & "." & Left(Cells(RowNdx, 4).Text & ",", 10) & _
Left("60" & ",", 10) & _
Format(ToDay, "yyyymmdd") & "," & _
Left(Hour & ",", 10) & _
Left(Int(Cells(RowNdx, 13).Value) & ",", 10) & _
Left(Int(Cells(RowNdx, 11).Value) & ",", 10) & _
Left(Int(Cells(RowNdx, 9).Value) & ",", 10) & _
Left(Int(Cells(RowNdx, 13).Value) & "," & SecVolume, 20) & _
Left(",0", 10)

Print #FNum, WholeLine
GoTo SkipLine:
End If

'For ColNdx = StartCol To EndCol
'WholeLine = WholeLine & Left(Cells(RowNdx, ColNdx).Text & _
'Space(Cells(1, ColNdx).Value), Cells(1, ColNdx).Value)
'Next ColNdx

If (Cells(RowNdx, 5).Text = "E,F") Then 'Eski Senetleri ve fonları al
GoTo SkipLine
End If

If (Cells(RowNdx, 1).Text = ">") Then
Imkb100Volume = Imkb100Volume + Cells(RowNdx, 23).Value
End If

'HİSSELER
WholeLine = WholeLine & Left(Cells(RowNdx, 4).Text & ",", 10) & _
Left("60" & ",", 10) & _
Format(ToDay, "yyyymmdd") & "," & _
Left(Hour & ",", 10) & _
Left(Cells(RowNdx, 13).Value & ",", 10) & _
Left(Cells(RowNdx, 11).Value & ",", 10) & _
Left(Cells(RowNdx, 9).Value & ",", 10) & _
Left(Cells(RowNdx, 13).Value & ",", 10) & _
Left(Cells(RowNdx, 23).Value & ",0" & Space(1), 20)
Print #FNum, WholeLine
SkipLine:
Next RowNdx

EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #FNum
Rows(1).Delete
ActiveWorkbook.Close savechanges:=True

Next Seans
End Sub

Bu makronun yarattığı *.prn dosyasının örneğinden bir bölüm veriyorum.

<TICKER>,<PER>,<DTYYYYMMDD>,<TIME>,<OPEN>,<HIGH>,<LOW>,<CLOSE>,<VOL>,<OPENINT>
ACIBD,60,20061113,120000,16.2,16.3,16,16.2,753,0
ADANA,60,20061113,120000,11,11.4,11,11,54835,0
ADBGR,60,20061113,120000,6.1,6.2,6.1,6.1,5052,0
ADNAC,60,20061113,120000,1.16,1.17,1.15,1.16,576000,0
ADEL,60,20061113,120000,6.95,7.05,6.9,6.95,24743,0
SASA,60,20061113,120000,0.91,0.92,0.91,0.91,677477,0
AFMAS,60,20061113,120000,5.02,5.16,5,5.02,70799,0
AFYON,60,20061113,120000,1190,1205,1190,1190,80,0
AKENR,60,20061113,120000,4.36,4.46,4.32,4.36,1292971,0
AKYO,60,20061113,120000,1.92,1.92,1.9,1.92,27837,0
AKALT,60,20061113,120000,4.78,4.78,4.36,4.78,239357,0
AKBNK,60,20061113,120000,8.25,8.5,8.2,8.25,3217059,0
AKCNS,60,20061113,120000,8.15,8.35,8.1,8.15,48994,0
ATEKS,60,20061113,120000,2.45,2.47,2.38,2.45,130807,0
AKMGY,60,20061113,120000,37.75,38.5,37.5,37.75,230,0
AKSA,60,20061113,120000,3.98,4.08,3.96,3.98,756551,0
AKGRT,60,20061113,120000,6.15,6.25,6.1,6.15,184262,0
AKSUE,60,20061113,120000,3.98,4.1,3.78,3.98,1451744,0
AKIPD,60,20061113,120000,2.26,2.3,2.23,2.26,270804,0
ALCAR,60,20061113,120000,16.8,16.9,16.7,16.8,878,0
ALGYO,60,20061113,120000,27,27.25,27,27,1851,0
ALARK,60,20061113,120000,3.96,4,3.94,3.96,361008,0
ALCTL,60,20061113,120000,4.72,4.76,4.66,4.72,427747,0
ALKA,60,20061113,120000,1.06,1.07,1.05,1.06,53521,0
ALKIM,60,20061113,120000,4.9,4.92,4.88,4.9,27018,0
ARFYO,60,20061113,120000,1.13,1.15,1.11,1.13,1275158,0
ALNTF,60,20061113,120000,2.9,3,2.88,2.9,1731536,0
ALYAG,60,20061113,120000,0.99,1.02,0.99,0.99,159409,0
ALTIN,60,20061113,120000,3.56,3.66,3.56,3.56,103001,0
ANACM,60,20061113,120000,5.15,5.25,5.1,5.15,11574,0
AEFES,60,20061113,120000,40.75,41.75,40.5,40.75,55553,0
ANHYT,60,20061113,120000,5,5.15,4.95,5,55576,0

Yukarıda adresi verilen excel Tablosunda E sutununda eski hisseler için (E) ve fonlar için (F)harfi yer almaktadır.Bazen bir hisse bölündüğünde yeni(Y)hisseler oluşmakta fakat bu makrolar ile yeni hisselere ait veriler *.prn dosyasına aktarılamamaktadır.Çünkü sadece D sutunundaki kodlar alındığında örneğin AKSUE hissesine ait eski hisseler AKSUE,yeni hisseler de AKSUE olarak bulunmaktadır.Bu durumda farklı iki veri aynı kodla tanımlanınca hata ortaya çıkmaktadır.

Bu kod makroda

If (Cells(RowNdx, 5).Text = "E,F") Then 'Eski Senetleri ve fonları al
GoTo SkipLine
End If
olarak bulunuyor.E sutununda bulunan E,F,Y harflerini hisse kodlarının yanına ALTIN.E,DJIMT.F,AKSUE.E,AKSU.Y biçiminde getirdiğimizde sorun çözülmüş olacak.

Emekli matematik öğretmeniyim.Amatörce borsa ile ilgileniyorum.Visual Basic dilini de bilmiyorum.Sadece bulduğum bu kodda anlattığım çözümü öğrenebilirsem bu yardımı yapacak kişiye minnet duyacağım.
Problemi özetlersem:

VBA makrosu ile excel tablosunun D sütununda bulunan hisse kodları *.prn dosyasına yazdırılırken E sutununda bulunan harfler hisse adının sonuna gelecek.

ALARK,60,20061113,120000,3.96,4,3.94,3.96,361008,0 şeklinde değil de

ALARK.E,60,20061113,120000,3.96,4,3.94,3.96,361008,0 şeklinde olacak.Ya da

DJIMT,60,20061113,120000,9.74,9.74,9.74,9.74,33014,0 şeklinde değil de

DJIMT.F,60,20061113,120000,9.74,9.74,9.74,9.74,33014,0 şeklinde olacak.(ALARK kodunun sağında E sutununda E harfi,DJIMT kodunun sağındaki E sutununda F harfi var.)

Yardımcı olacaklara şimdiden teşekkür ederim.
 
L

Levent Menteşoğlu

Administrator
Yönetici
Admin
Katılım
13 Ekim 2004
Mesajlar
16,057
Excel Vers. ve Dili
Excel 2010-32 bit-Türkçe
Excel 365 -32 bit-Türkçe
Kodunuzu daha da kısaltmak mümkün olabilir ama aşağıdaki gibi denerseniz sanırım istediğiniz olacaktır.

Kod: 
Sub MetaStockSeans()
Dim ToDay As String
Dim Hour As String
Dim Imkb100Volume As Currency
Dim ExchRate As Double
Dim SecVolume As String
Dim FName As String
Dim WholeLine As String
Dim FNum As Integer
Dim RowNdx As Single
Dim ColNdx As Integer
Dim StartRow As Single
Dim EndRow As Single
Dim StartCol As Integer
Dim EndCol As Integer
Dim StrFlag As Integer
Dim Seans As Integer
Dim Dizin As String
ToDay = Cells(3, 2).Text
Dizin = Cells(3, 5).Text & "\" & Format(ToDay, "yyyymmdd") & "\"
For Seans = 1 To 2
Imkb100Volume = 0
ExchRate = 1
StrFlag = 0
Workbooks.Open Filename:=Dizin & Format(ToDay, "yyyymmdd") & "s" & CStr(Seans) & ".xls"
FName = Application.GetSaveAsFilename(Left(ActiveWorkbook.FullName, _
Len(ActiveWorkbook.FullName) - 4) & ".prn")
Application.ScreenUpdating = False
On Error GoTo EndMacro:
FNum = FreeFile
Range("A1").EntireRow.Insert
myFormula = "=MAX(LEN(A2:A" & ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Row & "))+1"
Range("A1").FormulaArray = myFormula
Range("A1").AutoFill Destination:=Range(Cells(1, 1), Cells(1, _
ActiveSheet.UsedRange.Cells(ActiveSheet.UsedRange.Cells.Count).Column)), _
Type:=xlFillDefault

With Intersect(ActiveSheet.UsedRange, Rows("2:65536"))
StartRow = .Cells(1).Row
StartCol = .Cells(1).Column
EndRow = .Cells(.Cells.Count).Row
EndCol = .Cells(.Cells.Count).Column
End With
Open FName For Output Access Write As #FNum
If (Cells(StartRow, 15).Text = "1") Then
Hour = "120000"
Else
Hour = "160000"
End If
Print #FNum, "<TICKER>,<PER>,<DTYYYYMMDD>,<TIME>,<OPEN>,<HIGH>, <LOW>,<CLOSE>,<VOL>,<OPENINT>"
For RowNdx = StartRow To EndRow
WholeLine = ""
If (RowNdx < 8) Then GoTo SkipLine:
If (Cells(RowNdx, 4).Text = "") Then
GoTo SkipLine
End If
If (Cells(RowNdx, 4).Text = "KOD") Then
GoTo SkipLine
End If
If (Cells(RowNdx, 23).Value = 0) Then 'işlem olmamış tahtaları atla
GoTo SkipLine
End If
If (Cells(RowNdx, 4).Text = "XU100") Then
StrFlag = 1
SecVolume = Str(Imkb100Volume)
Else
SecVolume = "0"
End If
If (StrFlag = 1) Then 'Endeksler
WholeLine = WholeLine & "." & Left(Cells(RowNdx, 4).Text & ".", 10) & Cells(RowNdx, 5) & "," & _
Left("60" & ",", 10) & _
Format(ToDay, "yyyymmdd") & "," & _
Left(Hour & ",", 10) & _
Left(Int(Cells(RowNdx, 13).Value) & ",", 10) & _
Left(Int(Cells(RowNdx, 11).Value) & ",", 10) & _
Left(Int(Cells(RowNdx, 9).Value) & ",", 10) & _
Left(Int(Cells(RowNdx, 13).Value) & "," & SecVolume, 20) & _
Left(",0", 10)
Print #FNum, WholeLine
GoTo SkipLine:
End If
If (Cells(RowNdx, 5).Text = "E,F") Then 'Eski Senetleri ve fonları al
GoTo SkipLine
End If
If (Cells(RowNdx, 1).Text = ">") Then
Imkb100Volume = Imkb100Volume + Cells(RowNdx, 23).Value
End If
'HİSSELER
WholeLine = WholeLine & Left(Cells(RowNdx, 4).Text & ".", 10) & Cells(RowNdx, 5) & "," & _
Left("60" & ",", 10) & _
Format(ToDay, "yyyymmdd") & "," & _
Left(Hour & ",", 10) & _
Left(Cells(RowNdx, 13).Value & ",", 10) & _
Left(Cells(RowNdx, 11).Value & ",", 10) & _
Left(Cells(RowNdx, 9).Value & ",", 10) & _
Left(Cells(RowNdx, 13).Value & ",", 10) & _
Left(Cells(RowNdx, 23).Value & ",0" & Space(1), 20)
Print #FNum, WholeLine
SkipLine:
Next RowNdx
EndMacro:
On Error GoTo 0
Application.ScreenUpdating = True
Close #FNum
Rows(1).Delete
ActiveWorkbook.Close savechanges:=True
Next Seans
End Sub
 
D

diskriminant

Katılım
14 Kasım 2006
Mesajlar
16
Excel Vers. ve Dili
excel 2003
Sn leventm,
Makroda yaptığınız değişikliği uyguladım.Sonuç süper.Evet istediğim oldu.
Size ve tüm ekibinize sonsuz teşekkürler sunarım.
Emekli bir öğretmenin bilginin önemine bir kere daha huzurunuzda şahit olmasını sağladınız.Sağolun.
 
K

khanjar

Katılım
6 Aralık 2009
Mesajlar
4
Excel Vers. ve Dili
office 2007 türkçe
kusuruma bakmayın ben acemiyim. Peki bu işlemi yaptıktan sonra imkb excel dosyasını nasıl metastock datasına çevirebiliriz? yardımcı olursanız sevinirim.
 
D

diskriminant

Katılım
14 Kasım 2006
Mesajlar
16
Excel Vers. ve Dili
excel 2003
Sayın khanjar,
Yaklaşık 11 ay önce yazılmış iletinizi yeni gördüm.1.10.2010 tarihinde excel dosyalarında değişiklik yapıldı.Artık makrolar istediğim sonucu vermiyor.Bazı ek işlemlerle sonuca ulaşıyorum.Bu hemen hergün 15 dakikamı alıyor.Ve yine sanırım size en az 1 yıllık data da gerekir.Eğer hala daha ilginiz devam ediyorsa buradan yardımcı olmaya çalışırım.
 
K

khanjar

Katılım
6 Aralık 2009
Mesajlar
4
Excel Vers. ve Dili
office 2007 türkçe
diskriminant' Alıntı:
Sayın khanjar,
Yaklaşık 11 ay önce... Eğer hala daha ilginiz devam ediyorsa buradan yardımcı olmaya çalışırım.
Genişletmek için tıkla ...
Yaklaşık 9 ay sonra .....
:D

Sn. diskriminant ilgim devam ediyor.Bende manuel olarak verileri yazdırıyorum. Ekteki metin dosyasını geçici bültenler excel dosyasına yapıştırıp orada oluşan veriyi metin dosyasına yapıştırıyorum. ve ms downloader programı ile verileri atıyorum. Makro ile daha kolay atılırmı bilgi sahibi değilim.Yardımcı olabilirseniz sevinirim.Saygılarımla....
 

Ekli dosyalar

Cevap yazmak için giriş yap yada kayıt ol.
Üst