Hi all
Please help me to improve this vba code.
This sheet converts end of day stock data to metastock format data.
I want only "EQ" and "BE" data from attach csv file.
please help
[VBA]
Private Declare Function GetOpenFileName Lib "comdlg32.dll" Alias _
"GetOpenFileNameA" (pOpenfilename As OPENFILENAME) As Long
Private Type OPENFILENAME
lStructSize As Long
hwndOwner As Long
hInstance As Long
lpstrFilter As String
lpstrCustomFilter As String
nMaxCustFilter As Long
nFilterIndex As Long
lpstrFile As String
nMaxFile As Long
lpstrFileTitle As String
nMaxFileTitle As Long
lpstrInitialDir As String
lpstrTitle As String
flags As Long
nFileOffset As Integer
nFileExtension As Integer
lpstrDefExt As String
lCustData As Long
lpfnHook As Long
lpTemplateName As String
End Type
Private Sub Frame1_Click()
End Sub
Private Sub Frame2_Click()
End Sub
Private Sub cboxChooseFormula_Change()
Me.frameFormulaChoose.cmdOK.Enabled = True
End Sub
Private Sub CmdButSelectDir_Click()
Dim OpenFile As OPENFILENAME
Dim lReturn As Long
Dim sFilter As String
OpenFile.lStructSize = Len(OpenFile)
'OpenFile.hwndOwner = Form1.Hwnd
'OpenFile.hInstance = App.hInstance
sFilter = "All files (*.*)" & Chr(0) & "*.*" & Chr(0)
OpenFile.lpstrFilter = sFilter
OpenFile.nFilterIndex = 1
OpenFile.lpstrFile = String(257, 0)
OpenFile.nMaxFile = Len(OpenFile.lpstrFile) - 1
OpenFile.lpstrFileTitle = OpenFile.lpstrFile
OpenFile.nMaxFileTitle = OpenFile.nMaxFile
'OpenFile.lpstrInitialDir = "C:\"
OpenFile.lpstrTitle = "Select EODfile(in csv format) from the Directory Path"
OpenFile.flags = 0
lReturn = GetOpenFileName(OpenFile)
If lReturn <> 0 Then
TxtDisplayPath.Text = (Trim(OpenFile.lpstrFile))
TxtLoadFileName.Text = Trim(OpenFile.lpstrFileTitle)
End If
End Sub
Private Sub cmdClearData_Click()
End Sub
Private Sub cmdClearllData_Click()
End Sub
Private Sub cmdOK_Click()
Dim File_Names As Variant
Dim File_count As Integer
Dim Active_File_Name As String
Dim Counter As Integer
Dim File_Save_Name As Variant
File_Names = Application.GetOpenFileName("Csv Files (*.csv), *.csv", , "SELECT DOWNLOADED EOD FILE(S) FROM THE CORRESPONDING DATA DIRECTORY", , True)
Application.ScreenUpdating = False
Application.DisplayAlerts = False
Counter = 1
If IsArray(File_Names) Then
File_count = UBound(File_Names)
Do Until Counter > File_count
Active_File_Name = File_Names(Counter)
Dim Sheet1_Of_WB1 As String
Dim NewFileName As String
Dim NewActiveSheetName As String
Set WB1 = Workbooks.Open(Active_File_Name)
If Application.CountA(Worksheets(1).Cells) = 0 Then
WB1.Saved = True
WB1.Closed = True
Else 'Proceed the following steps as activeworksheet contains data
ActiveCell.CurrentRegion.Select
Selection.Copy
Sheet1_Of_WB1 = WB1.ActiveSheet.Name
Set WB2 = Workbooks.Add
If Me.cboxChooseFormula.Value = "Ticker,O,H,L,C,V,D" Then
WB2.Sheets(1).Name = Sheet1_Of_WB1
NewActiveSheetName = WB2.Sheets(1).Name
WB2.Sheets(1).Paste
Columns("C:C").Select
Selection.Cut
Columns("B:B").Select
ActiveSheet.Paste
Columns("D").Select
Selection.Cut
Columns("C:C").Select
ActiveSheet.Paste
Columns("E:E").Select
Selection.Cut
Columns("D
ActiveSheet.Paste
Columns("F:F").Select
Selection.Cut
Columns("E:E").Select
ActiveSheet.Paste
Columns("I:I").Select
Selection.Cut
Columns("F:F").Select
ActiveSheet.Paste
Columns("K:K").Select
Selection.Cut
Columns("G:G").Select
ActiveSheet.Paste
'Columns("I:I").Select
'Selection.Insert Shift:=xlToRight
Columns("H:H").Select
Selection.Clear
Columns("J:J").Select
Selection.Clear
Range("A1").Select
ActiveCell.FormulaR1C1 = "TICKER"
Range("F1").Select
ActiveCell.FormulaR1C1 = "VOLUME"
Range("G1").Select
ActiveCell.FormulaR1C1 = "DATE"
NewFileName = NewActiveSheetName & ".xls"
'Depending on the users excel's settings,
'there could be many worksheet when starting a workbook.
'Ensure there is only one worksheet.
Dim i As Integer
For i = WB2.Worksheets.Count To 2 Step -1
WB2.Sheets(i).Delete
Next i
End If
If Me.cboxChooseFormula.Value = "Ticker,D,O,H,L,C,V" Then
WB2.Sheets(1).Name = Sheet1_Of_WB1
NewActiveSheetName = WB2.Sheets(1).Name
WB2.Sheets(1).Name = Sheet1_Of_WB1
NewActiveSheetName = WB2.Sheets(1).Name
WB2.Sheets(1).Paste
Columns("K:K").Select
Selection.Cut
Columns("B:B").Select
ActiveSheet.Paste
Columns("I:I").Select
Selection.Cut
Columns("G:G").Select
ActiveSheet.Paste
'Columns("I:I").Select
'Selection.Insert Shift:=xlToRight
Columns("H:H").Select
Selection.Clear
Columns("J:J").Select
Selection.Clear
Range("A1").Select
ActiveCell.FormulaR1C1 = "TICKER"
Range("B1").Select
ActiveCell.FormulaR1C1 = "DATE"
Range("G1").Select
ActiveCell.FormulaR1C1 = "VOLUME"
NewFileName = NewActiveSheetName & ".xls"
Dim j As Integer
For j = WB2.Worksheets.Count To 2 Step -1
WB2.Sheets(j).Delete
Next j
End If
Dim strFolder As String
' Dim NewFolder
Dim fso
Set fso = CreateObject("Scripting.FileSystemObject")
strFolder = WB1.Path
WB1.Saved = True
WB1.Close True
If Len(strFolder) = 0 Then strFolder = CurDir
If Me.cboxChooseFormula.Value = "Ticker,O,H,L,C,V,D" Then
strFolder = strFolder & "\METASTK_EXCEL_OHLCVD\"
If fso.FolderExists(strFolder) <> True Then
fso.CreateFolder (strFolder)
strNewFilePath = strFolder & NewFileName
ActiveWorkbook.SaveAs Filename:=strNewFilePath, FileFormat:=xlNormal, ReadOnlyRecommended:=False, CreateBackup:=False
WB2.Saved = True
WB2.Close True
End If
Else
If Me.cboxChooseFormula.Value = "Ticker,D,O,H,L,C,V" Then
strFolder = strFolder & "\METASTK_EXCEL_DOHLCV\"
If fso.FolderExists(strFolder) <> True Then
fso.CreateFolder (strFolder)
strNewFilePath = strFolder & NewFileName
ActiveWorkbook.SaveAs Filename:=strNewFilePath, FileFormat:=xlNormal, ReadOnlyRecommended:=False, CreateBackup:=False
WB2.Saved = True
WB2.Close True
End If
End If
End If
' If fso.FolderExists(strFolder) <> True Then
' fso.CreateFolder (strFolder)
' End If
' strNewFilePath = strFolder & NewFileName
'-----------------------------
'ActiveWorkbook.SaveAs Filename:=strNewFilePath, FileFormat:=xlNormal, ReadOnlyRecommended:=False, CreateBackup:=False
''WB1.Saved = True
'' WB1.Close True
' WB2.Saved = True
' WB2.Close True
End If
'--------------------------------------------
'End If
Counter = Counter + 1
Loop
End If
Application.ScreenUpdating = True
Application.DisplayAlerts = True
frameFormulaChoose.Enabled = True
End Sub
Private Sub TextBox2_Change()
End Sub
Private Sub frameStkName_Click()
End Sub
Private Sub ModeOfDataEntry_Click()
End Sub
Private Sub OptionButton1_Click()
'txtStkName.SetFocus
frameFormulaChoose.Enabled = False
End Sub
Private Sub UserForm_Initialize()
Me.frameFormulaChoose.Enabled = True
With Me.cboxChooseFormula
.AddItem "Ticker,O,H,L,C,V,D"
.AddItem "Ticker,D,O,H,L,C,V"
End With
End Sub
[/VBA]
Reply With Quote
