imkbdata

[diskriminant]

1.10.2010 tarihinde yapılan değişiklikle bazı hisseler A,B,c gruplarına ayrıldı.2.seansa
daha önce olmayan günlük ağırlıklı ortalama eklendi.Eski xls dosyalarında örneğin 4.sütun
daki kodlar yeni xls dosyasında 9.sütunda.Yeni düzenlemeye uygun değişiklik yaptım.Ancak
Seans makrosunun ürettiği txt dosyasında 2 hata görüyorum.

1)1.seans saati 123000 olması gerekirken 173000 olarak yazılıyor.
2)1.seansta endeks bilgileri yer alırken 2.seansta endeks bilgilerini makro yazmıyor.

Bu iki hatanın nedenini bulamadım.Emekli öğretmenim.Borsa ile sadece izleyici olarak ilgi
leniyorum.Makro kodlarını öğrenmeğe çalışıyorum.Bilgi dünyasına balıklama atlamanın bilim
sel olmadığını biliyorum.Adım adım ilerlemeli.Bu da şimdilik benim boyumu aşıyor.
Yardımcı olan bilgili arkadaşlara şimdiden teşekkür ederim.Kodlar aşağıda.Bu kodlar hangi
değişiklikle doğru data dosyası üretir.

Sub MetaStockSeans()

' Macro recorded 01/10/2010 by derici
'

'
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) & ".txt")

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 = "123000"
Else
Hour = "173000"
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, 9).Text = "") Then
GoTo SkipLine
End If

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

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

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

If (StrFlag = 1) Then 'Endeksler
WholeLine = WholeLine & Left(Cells(RowNdx, 9).Text & ",", 15) & _
Left("60" & ",", 15) & _
Format(ToDay, "yyyymmdd") & "," & _
Left(Hour & ",", 15) & _
Left(Int(Cells(RowNdx, 14).Value) & ",", 15) & _
Left(Int(Cells(RowNdx, 18).Value) & ",", 15) & _
Left(Int(Cells(RowNdx, 16).Value) & ",", 15) & _
Left(Int(Cells(RowNdx, 20).Value) & "," & SecVolume, 25) & _
Left(",0", 15)

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, 10).Text = "") Then 'Eski,Yeni Senetleri ve fonları al
GoTo SkipLine
End If

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

'HİSSELER
WholeLine = WholeLine & Left(Cells(RowNdx, 9).Text & ".", 15) & Cells(RowNdx, 10) & "," & _
Left("60" & ",", 15) & _
Format(ToDay, "yyyymmdd") & "," & _
Left(Hour & ",", 15) & _
Left(Cells(RowNdx, 14).Value & ",", 15) & _
Left(Cells(RowNdx, 18).Value & ",", 15) & _
Left(Cells(RowNdx, 16).Value & ",", 15) & _
Left(Cells(RowNdx, 20).Value & ",", 15) & _
Left(Cells(RowNdx, 30).Value & ",0" & Space(1), 25)
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

 

[diskriminant]

imkb datası üreten xls dosyasını da ekliyorum.