Data Generator V3

Hi Experts,

Need change in VBA as it cut past data from sheet EOD to respective symbol by clicking (Ctrl+o).but problem arise when for the same date i run this macro twice or may be more it add line to symbol sheet for same date not over pasting on same date.& if it is possible in EOD sheet when i run macro then all data is disappear i want at name column data so i can link data from other sheet by using vlookup function.

pls see attached file....

Thank You
EOD-V3.xlsm
itjockey79Asked:
Who is Participating?
 
redmondbCommented:
itjockey79,

i am not talking about Name as header it is remain i am concern about name column i.e ACC LTD ,L&T  .....& so on but that requirement is not need it
Apologies, I still don't understand this. Please see attached (code below). If the results it gives are not correct, please manually correct the file and post it here - I'll change the code to match your changes.

 The code is...
Sub process_new_data()
Dim src As Worksheet
Dim dst As Worksheet
Dim row As Range
Dim xName As Range
Dim xFind As Range
Dim xLast_Row As Long
Dim xLast_Col As Long
Dim xResponse As Long
Dim xBB_Last_Row As Long

'-- locate source data with updates
Set src = Worksheets("EOD")
xLast_Row = src.Range("A1").SpecialCells(xlLastCell).row
xLast_Col = src.Range("A1").SpecialCells(xlLastCell).Column

'-- parse each row with updated data
For Each xName In src.Range("A1:A" & xLast_Row)
    
    '-- skip header rows
    If xName <> "Name" And xName <> "" Then
    
        '-- Check than each non-blank entry has a date. (Because we need to use that Date later.)
        If xName.Offset(0, 1) = "" Then
        
            xResponse = MsgBox(xName & "'s Date is blank." & Chr(10) _
                            & """OK"" to skip this entry or ""Cancel"" to terminate run.", vbOKCancel, "Process New Data")
            If xResponse = 2 Then
                MsgBox ("Run terminating...")
                Application.StatusBar = False
                Exit Sub
            End If
        
        Else
        
            Application.StatusBar = "Updating " & xName
            
            '-- locate destination sheet
            If Not exists(xName.Value) Then
                MsgBox "No worksheet found for " & xName & ", generating one"
                Set dst = Worksheets.Add
                dst.name = xName
                dst.Range("A21") = xName
                dst.Range("A21:F21").Merge
                dst.Range("A22") = "Date"
                dst.Range("B22") = "Open"
                dst.Range("C22") = "High"
                dst.Range("D22") = "Low"
                dst.Range("E22") = "Close"
                dst.Range("F22") = "Volume"
                
                '-- Create "BB" entry.
                xBB_Last_Row = 1 + Sheets("BB").Range("A1").SpecialCells(xlLastCell).row
                src.Range("A" & xName.row & ":G" & xName.row).Copy Sheets("BB").Range("B" & xBB_Last_Row)
                Sheets("BB").Range("C" & xBB_Last_Row).Formula = "=BDH(A" & xBB_Last_Row & ",""PX_OPEN, PX_HIGH, PX_LOW, PX_LAST, PX_VOLUME"",$N$1,$N$1,""Dts=S"",""cols=6;rows=1"")"
            Else
                Set dst = Worksheets(xName.Value)
            End If
            
            '-- Check no entry exists for this date.
            Set xFind = dst.Columns(1).Find(What:=xName.Offset(0, 1), LookAt:=xlWhole)
            If xFind Is Nothing Then
                '-- move data to appropriate sheet
                '-- restrict data insertion to A23:F1500
                dst.Range("A23:F1499").Copy dst.Range("A24:F1500")
                src.Range("B" & xName.row & ":G" & xName.row).Copy dst.Range("A23")
            Else
                src.Range("B" & xName.row & ":G" & xName.row).Copy xFind 'dst.Range("A23")
            End If
        
        End If
        
    End If

Next xName

src.Range("B2", src.Cells(xLast_Row, xLast_Col)).Delete xlShiftToLeft
    
Application.StatusBar = False

End Sub

Open in new window

Thanks,
Brian.EOD-V3C.xlsm
0
 
redmondbCommented:
Hi, itjockey79.

Please see the code below. It assumes that there will be a header row on the EOD sheet. Please let me know if this is not always the case.
Sub process_new_data()
Dim src As Worksheet
Dim dst As Worksheet
Dim row As Range
Dim xName As Range
Dim xFind As Range
Dim xLast_Row As Long
Dim xLast_Col As Long
Dim xResponse As Long

'-- locate source data with updates
Set src = Worksheets("EOD")
xLast_Row = src.Range("A1").SpecialCells(xlLastCell).row
xLast_Col = src.Range("A1").SpecialCells(xlLastCell).Column

'-- parse each row with updated data
For Each xName In src.Range("A1:A" & xLast_Row)
    
    '-- skip header rows
    If xName <> "Name" And xName <> "" Then
    
        '-- Check than each non-blank entry has a date. (Because we need to use that Date later.)
        If xName.Offset(0, 1) = "" Then
        
            xResponse = MsgBox(xName & "'s Date is blank." & Chr(10) _
                            & """OK"" to skip this entry or ""Cancel"" to terminate run.", vbOKCancel, "Process New Data")
            If xResponse = 2 Then
                MsgBox ("Run terminating...")
                Application.StatusBar = False
                Exit Sub
            End If
        
        Else
        
            Application.StatusBar = "Updating " & xName
            
            '-- locate destination sheet
            If Not exists(xName.Value) Then
                MsgBox "No worksheet found for " & xName & ", generating one"
                Set dst = Worksheets.Add
                dst.name = xName
                dst.Range("A21") = xName
                dst.Range("A21:F21").Merge
                dst.Range("A22") = "Date"
                dst.Range("B22") = "Open"
                dst.Range("C22") = "High"
                dst.Range("D22") = "Low"
                dst.Range("E22") = "Close"
                dst.Range("F22") = "Volume"
            Else
                Set dst = Worksheets(xName.Value)
            End If
            
            '-- Check no entry exists for this date.
            Set xFind = dst.Columns(1).Find(What:=xName.Offset(0, 1), LookAt:=xlWhole)
            If xFind Is Nothing Then
                '-- move data to appropriate sheet
                '-- restrict data insertion to A23:F1500
                dst.Range("A23:F1499").Copy dst.Range("A24:F1500")
                src.Range("B" & xName.row & ":G" & xName.row).Copy dst.Range("A23")
            Else
                xResponse = MsgBox(xName & " already has data for " & Format(xName.Offset(0, 1), "dd/mm/yyyy") & "." _
                    & Chr(10) & """OK"" to skip this entry or ""Cancel"" to terminate run.", vbOKCancel, "Process New Data")
                If xResponse = 2 Then
                    MsgBox ("Run terminating...")
                    Application.StatusBar = False
                    Exit Sub
                End If
                
            End If
        
        End If
        
    End If

Next xName

src.Range("B2", src.Cells(xLast_Row, xLast_Col)).Delete xlShiftToLeft
    
Application.StatusBar = False


End Sub

Open in new window

Regards,
Brian.
0
 
itjockey79Author Commented:
yes in header in EOD always Name date open high low close volume want to header always be there but also name column data,as i can link rest data by vlookup & new data on same date should be over past on respective sheet,

pls provide file dont wana to spoil code while pasting in VBA screen...


Thank You
0
Ultimate Tool Kit for Technology Solution Provider

Broken down into practical pointers and step-by-step instructions, the IT Service Excellence Tool Kit delivers expert advice for technology solution providers. Get your free copy now.

 
redmondbCommented:
itjockey79,

Please see attached. The second "EOD" was just for testing. BTW, do you mean to have all the blank rows at the end of each sheet?

dont wana to spoil code while pasting in VBA screen...
?!

Regards,
Brian.EOD-V3B.xlsm
0
 
itjockey79Author Commented:
Hi Brian,

pls see attache file & its comment,& Send file in return.



Thank You
EOD-V3B.xlsm
0
 
redmondbCommented:
itjockey79,

Please confirm...

(1) If an entry already exists for a company for the date then the old entry should be overwritten. (Apologies, I missed this in your original request.)

(2) On the EOD sheet, you mention "step 1 :- this shud remain after code run." I can't find any way to repeat this - no matter what data I use, the name is always left behind.

Thanks,
Brian.
0
 
itjockey79Author Commented:
yes step1

step 2 it is ok if names not remain bcoz if code run then formula also wiped out,so no need to remain name but you can see in my 1 attached sheet there is one more thing if any new entry comes which is not in symbol sheet then it creates new sheet for that name so pls let that process remain same.for data i used one more sheet which is BB & i had recorded macro to copy past on EOD then i run (Ctrl+o) .no step 2 4got it but be sure sir if any new entry come then create new sheet for that entry.
0
 
redmondbCommented:
itjockey79,

(1) "yes step1"
Thanks.

(2) "it is ok if names not remain"
I've tried but no matter what I do the Names always remain. How are you getting rid of them?

(3) "it creates new sheet for that name"
That code is working fine for me. Is it not working for you?

(4) "if any new entry come then create new sheet for that entry"
Sure, but I'll hold off until I've got your answers to (3) and (4).

Thanks,
Brian.
0
 
itjockey79Author Commented:
yes create new sheet if new symbol is there is in eOD sheet

i am not talking about Name as header it is remain i am concern about name column i.e ACC LTD ,L&T  .....& so on but that requirement is not need it
   

now only just data over paste on same date & new sheet creation if new symbol is there in EOD sheet i.e current 51 symbol but if new 5 symbol added new sheet created of that name
0
 
Arno KosterCommented:
please update
            '-- move data to appropriate sheet
            '-- restrict data insertion to A23:F1500
            dst.Range("A23:F1499").Copy dst.Range("A24:F1500")
            src.Range("B" & row.row & ":G" & row.row).Copy dst.Range("A" & 23)

Open in new window

to
            '-- move data to appropriate sheet
            '-- restrict data insertion to A23:F1500
            dim result as range
            Set result = dst.Range("A:A").Find(what:=src.Range("B" & row.row))
            If result Is Nothing Then
                '-- if entry with same date cannot be found,
                '-- insert new row restrict data insertion to A23:F1500
                dst.Range("A23:F1499").Copy dst.Range("A24:F1500")
                src.Range("B" & row.row & ":G" & row.row).Copy dst.Range("A" & 23)
            Else
                '-- otherwise, overwrite the line
                src.Range("B" & row.row & ":G" & row.row).Copy dst.Range("A" & result.row)
            End If

Open in new window

0
 
redmondbCommented:
Hi, akoster.

Your code appears to handle duplicate dates in a similar way to mine, but doesn't include the other functionality that the OP requested. I'm not sure what it brings to the party!

Regards,
Brian.
0
 
itjockey79Author Commented:
Thank You
0
 
redmondbCommented:
Thanks, itjockey79.
0
 
Naresh PatelTraderCommented:
Hi Sir,
Happy New Year
0
Question has a verified solution.

Are you are experiencing a similar issue? Get a personalized answer when you ask a related question.

Have a better answer? Share it in a comment.

All Courses

From novice to tech pro — start learning today.