PDA

View Full Version : Filter column data from csv file



samvet
03-02-2008, 08:39 PM
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

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:D").Select
Selection.Cut
Columns("C:C").Select
ActiveSheet.Paste

Columns("E:E").Select
Selection.Cut
Columns("D:D").Select
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

Bob Phillips
03-03-2008, 02:13 AM
You can make it a lot smaller by getting rid of the API file open (you use GetOpenFileName method later on), and removing all of the selecting, for instance#



Columns("J:J").Select
Selection.Clear
Range("A1").Select
ActiveCell.FormulaR1C1 = "TICKER"


becomes



Columns("J:J").Clear
Range("A1").Value = "TICKER"


etc.

But are you looking for some functional change in this code? If so, what exactly?