Solved

Formatting BSEeq

Posted on 2015-01-19
10
91 Views
Last Modified: 2015-01-20
Hi Experts,

I have one file which download zip files from web & unzipped that files.
need to add one step further on this unzipped files.

As in each files date column is missing which is mention on each file tab.
need to add date column in place of D column i.e. replacing SC_TYPE column with Date.
No need to add new column as I want 13 columns not more that that after this formatting done.

See attached I referring "Equity BSE" Button. And Changes is attached below.BeforeAfterFrom Where Date To Take


Thanks
Incoporated-Download-File-V05.xlsm
0
Comment
Question by:itjockey
  • 5
  • 4
10 Comments
 
LVL 18

Expert Comment

by:SimonAdept
ID: 40559287
I haven't looked at your workbook, but adding something like this would do it.
Sub SheetNameDateToCol4()
    ActiveSheet.Cells(1, 4).Value = "Date"
    shtname = ActiveSheet.Name
    Range(Cells(2, 4), Cells(ActiveSheet.UsedRange.Rows.Count, 4)) = DateSerial(CInt(Right(shtname, 2)) + 2000, Mid(shtname, 5, 2), Mid(shtname, 3, 2))
End Sub

Open in new window

0
 
LVL 29

Expert Comment

by:gowflow
ID: 40559434
So is this to apply for Equity BSE of FO ?
gowflow
0
 
LVL 8

Author Comment

by:itjockey
ID: 40559459
This is apply to BSE Equity.

Thanks
0
 
LVL 29

Accepted Solution

by:
gowflow earned 500 total points
ID: 40559486
ok here it is:

1) Make a new copy of your current workbook and give it a new name.
2) open VBA and doubleclick on the module aStartEquityBSE
3) Select ALL the code that is there and DELETE IT.
4) Paste the below code in this module. You should get 2 Sub
FormatingEquityBSE
DownloadFileEquityBSE


Function FormatingEquityBSE(sType As String, sFolder As String) As String
On Error GoTo ErrHandler

Dim WB As Workbook
Dim WS As Worksheet
Dim WSAudit As Worksheet
Dim WSMain As Worksheet
Dim MaxRow As Long, MaxCol As Long, MaxRowA As Long, I As Long, J As Long
Dim lUns As Long, lRows As Long
Dim Rng As Range, cRow As Range
Dim sFile As String, sDirName As String, sDate As String, Res As String
Dim colFiles As New Collection
Dim vFile As Variant
    
'---> Set Variables
Set WSAudit = Sheets("Audit")
MaxRowA = WSAudit.Range("A" & WSAudit.Rows.Count).End(xlUp).Row
If MaxRowA = 1 Then MaxRowA = MaxRowA + 1
Set WSMain = ActiveSheet

'---> Get the Recursive Files and folders
RecursiveDir colFiles, sFolder, "*.csv", True

For Each vFile In colFiles
           
    '---> Get full name
    sFile = Dir(vFile)
    sDirName = Mid(vFile, 1, InStrRev(vFile, "\"))
    
    '---> Update Trace
    If Not bTrace Then
        WSMain.Cells(14, "A").EntireRow.Insert
        WSMain.Cells(14, "A") = sType
        WSMain.Cells(14, "B") = sDirName
        WSMain.Cells(14, "C") = sFile
    End If
    
    '---> Disable Events
    With Application
        .EnableEvents = False
        .DisplayAlerts = False
        .ScreenUpdating = False
    End With
    
    '---> Open workbook and affect variables
    Set WB = Workbooks.Open(vFile)
    Set WS = WB.ActiveSheet
    MaxRow = WS.UsedRange.Rows.Count
    MaxCol = WS.UsedRange.Columns.Count
    
    
    sDate = Mid(WS.Name, 5, 2) & "/" & Mid(WS.Name, 3, 2) & "/" & Mid(WS.Name, 7, 2)
    WS.Range("D1") = "Date"
    WS.Range("D2:D" & MaxRow) = sDate
    
            
    '---> Register the record found in Audit
    If Not bAudit Then
        WSAudit.Cells(MaxRowA, "A") = Now
        WSAudit.Cells(MaxRowA, "B") = sFile
        WSAudit.Cells(MaxRowA, "C") = sDate
        MaxRowA = MaxRowA + 1
    End If
    
    '---> Update Trace
    If Not bTrace Then
        WSMain.Cells(14, "A").EntireRow.Insert
        WSMain.Cells(14, "A") = sType
        WSMain.Cells(14, "B") = sDirName
        WSMain.Cells(14, "C") = sFile
        WSMain.Cells(14, "D") = sDate
        WSMain.Cells(14, "F") = "Formated"
    End If
    DoEvents
    
    '---> Save workbook
    WB.Close savechanges:=True
        
    '---> reset Variables
    Set WS = Nothing
    Set WB = Nothing
    
    '---> Enable Events
    With Application
        .EnableEvents = True
        .DisplayAlerts = True
        .ScreenUpdating = True
    End With
    
Next vFile

'---> fix Layout
If Not bAudit Then
    WSAudit.UsedRange.EntireColumn.AutoFit
End If

'---> Set Flag to complete successful and exit
FormatingEquityBSE = ""
Exit Function

ErrHandler:
MsgBox (Error(Err))
FormatingEquityBSE = Error(Err)
Resume
On Error GoTo 0

End Function



''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
' DownloadFileEquityBSE
' This downloads a file from a URL to a local filename.
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
Public Function DownloadFileEquityBSE(Overwrite As DownloadFileDisposition) As Boolean
    Dim WSMain As Worksheet
   
    Dim DestinationFileName As String
    Dim Disp As DownloadFileDisposition
    Dim Res As VbMsgBoxResult
    Dim ErrorText As String
    Dim B As Boolean
    Dim S As String
    Dim L As Long
    Dim MaxRowM As Long
    
    'Dim strStartDate As String
    'Dim strEndDate As String
    Dim datLastDate As Date
    Dim datWorkDate As Date
    Dim iYear As Integer
    Dim strMonth As String
    Dim strDay As String
    Dim strFileName As String
    Dim strFilePath As String
    Dim strSavePath As String
    Dim sLastDownloadeddate As String
    Dim oFso As Object

    
    Set WSMain = ActiveSheet

    '---> Clean Previous Trace
    WSMain.Range("A14:I" & WSMain.Rows.Count).ClearContents
    MaxRowM = 14
    
    
    ErrorText = vbNullString

    strSavePath = gstDestinationFolder
    
    If Not bTrace Then
        WSMain.Cells(14, "A").EntireRow.Insert
        WSMain.Cells(14, "A") = "Equity BSE"
        WSMain.Cells(14, "B") = strSavePath
        WSMain.Cells(14, "C") = "*.*"
        WSMain.Cells(14, "F") = "Deleting"
        'MaxRowM = MaxRowM + 1
    End If
    
    '---> Delete All files in Directory prior to proceeding
    DeleteFiles strSavePath
    
    Set oFso = CreateObject("Scripting.FileSystemObject")

    With oFso
        If Not .FolderExists(strSavePath) Then
            MakeMultiStepDirectory strSavePath
        End If
    End With

    
    If dEndDate = vbEmpty Or dStartDate = vbEmpty Then
        MsgBox "Missing either Strat Date or End Date procedure will exit.", vbCritical
        Exit Function
    End If
    
    datLastDate = DateValue(dEndDate)      'DateSerial(iYear, 4, 9)
    datWorkDate = DateValue(dStartDate)    'DateSerial(iYear, 1, 1)
    
    
    Do
        ' EG http://www.bseindia.com/download/BhavCopy/Equity/EQ291214_CSV.ZIP
        strFileName = "EQ" & Format(datWorkDate, "ddmmyy") & "_CSV.ZIP"    ' e.g. EQ291214_CSV.ZIP
        strFilePath = sHTTP & strFileName
        
        If Right(strSavePath, 1) <> "\" Then strSavePath = strSavePath & "\"

        DestinationFileName = strSavePath & strFileName

        If Dir(DestinationFileName, vbNormal) <> vbNullString Then
            Select Case Overwrite
                Case OverwriteKill
                    On Error Resume Next
                    Err.Clear
                    Kill DestinationFileName
                    If Err.Number <> 0 Then
                        ErrorText = "Error Killing file '" & DestinationFileName & "'." & vbCrLf & Err.Description
                        DownloadFileEquityBSE = False
                    End If

                Case OverwriteRecycle
                    On Error Resume Next
                    Err.Clear
                    B = RecycleFileOrFolder(DestinationFileName)
                    If B = False Then
                        ErrorText = "Error Recycleing file '" & DestinationFileName & "." & vbCrLf & Err.Description
                        DownloadFileEquityBSE = False
                        Exit Function
                    End If

                Case DoNotOverwrite
                    DownloadFileEquityBSE = False
                    ErrorText = "File '" & DestinationFileName & "' exists and disposition is set to DoNotOverwrite."
                    Exit Function

                    'Case PromptUser
                Case Else
                    S = "The destination file '" & DestinationFileName & "' already exists." & vbCrLf & _
                        "Do you want to overwrite the existing file?"
                    Res = MsgBox(S, vbYesNo, "Download File")
                    If Res = vbNo Then
                        ErrorText = "User selected not to overwrite existing file."
                        DownloadFileEquityBSE = False
                        Exit Function
                    End If
                    B = RecycleFileOrFolder(DestinationFileName)
                    If B = False Then
                        ErrorText = "Error Recycling file '" & DestinationFileName & "." & vbCrLf & Err.Description
                        DownloadFileEquityBSE = False
                        Exit Function
                    End If
            End Select
        End If
        Debug.Print strFilePath & " validity: " & GetURLStatus(strFilePath)
        If GetURLStatus(strFilePath) = "200 - OK" Then
            L = DeleteUrlCacheEntry(strFilePath)
            L = URLDownloadToFile(0&, strFilePath, DestinationFileName, 0&, 0&)
            Select Case L
                Case Is = 0
                    DownloadFileEquityBSE = True
                    sLastDownloadeddate = datWorkDate
                    
                    '---> Update Trace
                    If Not bTrace Then
                        WSMain.Cells(14, "A").EntireRow.Insert
                        WSMain.Cells(14, "A") = "Equity BSE"
                        WSMain.Cells(14, "B") = strSavePath
                        WSMain.Cells(14, "C") = strFileName
                        WSMain.Cells(14, "F") = "Created"
                        'MaxRowM = MaxRowM + 1
                    End If
                Case Is = -2146697210
                    ErrorText = "File not found."
                    DownloadFileEquityBSE = False
                Case Is = -2146697211
                    ErrorText = "Domain not found."
                    DownloadFileEquityBSE = False
                Case Is = -2147467260
                    ErrorText = "Transfer aborted."
                    DownloadFileEquityBSE = False
                Case Else
                    ErrorText = "Buffer length invalid or not enough memory."
                    DownloadFileEquityBSE = False
            End Select
        End If
        datWorkDate = DateAdd("d", 1, datWorkDate)
    Loop Until datWorkDate > datLastDate

'---> Set New Start Date = last successful date + Clear End Date
If sLastDownloadeddate <> "" Then
    Range("E8").Value = DateAdd("d", 1, sLastDownloadeddate)
    Range("F8").Formula = "=Today()"
    'MsgBox "Last Successful downloaded file was on " & sLastDownloadeddate & Chr(10) & "The next set date for next run of the routine will be set at " & Range("G3").Value
Else
    Range("F8").Formula = "=Today()"
    'MsgBox "No Files where found in this Interval try later."
End If

End Function

Open in new window


5) SAVE the workbook.
6) Doubleclick on sheet Main and select commandbutton6 and delete all the code that is there.
7) Paste the below code after commandbutton6_click

bTrace = CheckBox21.Value
bAudit = CheckBox22.Value
gstDestinationFolder = Range("B8")
If bTesting Then gstDestinationFolder = ActiveWorkbook.Path & "\Temp\"
dStartDate = Range("E8")
dEndDate = Range("F8")
sHTTP = Sheets("Settings").Range("B7")

'---> Start Download
DownloadFileEquityBSE (OverwriteRecycle)

'---> Part of Unzipping files
UnzipAllFiles CommandButton6.Caption

'---> Formating Equity BSE
FormatingEquityBSE CommandButton6.Caption, gstDestinationFolder

MsgBox ("Equity BSE Done")

Open in new window


8) SAVE and Exit the workbook.
9) open it and give it a try.

gowflow
0
 
LVL 8

Author Closing Comment

by:itjockey
ID: 40560102
Guruji Perfect...May I Ask last question on this series ?
0
Threat Intelligence Starter Resources

Integrating threat intelligence can be challenging, and not all companies are ready. These resources can help you build awareness and prepare for defense.

 
LVL 29

Expert Comment

by:gowflow
ID: 40560123
Just wait for me 1/2 hour hv errans to run !!!! :) when wife ask .... its an order !!! :)
gowflow
0
 
LVL 8

Author Comment

by:itjockey
ID: 40560132
Same story over the globe .....I can understand :)
0
 
LVL 29

Expert Comment

by:gowflow
ID: 40560290
PLs go ahead
gowflow
0
 
LVL 8

Author Comment

by:itjockey
ID: 40560475
1 min Sir.

Thanks
0
 
LVL 8

Author Comment

by:itjockey
ID: 40560491
Here It Is.

Thanks
0

Featured Post

How your wiki can always stay up-to-date

Quip doubles as a “living” wiki and a project management tool that evolves with your organization. As you finish projects in Quip, the work remains, easily accessible to all team members, new and old.
- Increase transparency
- Onboard new hires faster
- Access from mobile/offline

Join & Write a Comment

Suggested Solutions

Improved? Move/Copy Add-in Replacement - How to avoid the annoying, “A formula or sheet you want to move or copy contains the name XXX, which already exists on the destination worksheet.” David Miller (dlmille)  It was one of those days… I wa…
This code takes an Excel list of URL’s and adds a header titled “URL List”. It then searches through all URL’s in column “A”, looking for duplicates. When a duplicate is found, it is moved to the top of the list. The duplicate URL’s are then highlig…
Graphs within dashboards are meant to be dynamic, representing data from a period of time that will change each time the dashboard is updated with new data. Rather than update each graph to point to a different set within a static set of data, t…
Polish reports in Access so they look terrific. Take yourself to another level. Equations, Back Color, Alternate Back Color. Write easy VBA Code. Tighten space to use less pages. Launch report from a menu, considering criteria only when it is filled…

708 members asked questions and received personalized solutions in the past 7 days.

Join the community of 500,000 technology professionals and ask your questions.

Join & Ask a Question

Need Help in Real-Time?

Connect with top rated Experts

12 Experts available now in Live!

Get 1:1 Help Now