MACRO or VBA Required

[aacod]

I need a macro or a VBA to do the following:

From workbook named ’CurrencyEXG’, Copy the contents from sheet named ‘Data’ under column B from Cells B5 to B370.

Paste the copied contents to another workbook named ‘Tickers’ starting from Sheet 2 to Sheet 200 under columns H by putting header in cell H2 as ‘USDCURR’ and paste the copied contents from cell H3 to H367.

Then put a Header in cell I2 as ‘Price’ with a formula under Column ‘I’ from cells I3 to I367 giving the result =(G3*H3) rounded to 2 figures.

Thanks.

aacod.

[jolivanes]

When you ran the macro recorder to do this, what did you get after you cleaned the code up?

[aacod]

Hi jolivanes,

To simplify I did the following:

Copied the contents from CurrencyExg from cell A1:B366, created a new sheet 'Currency' in workbook Tickers and pasted the contents on to the newly created currency sheet.

Started Macro1 to do the following:
I copied the contents from Cells A1:B366 and pasted under column H on to all the ticker named sheets from cell H2 downwards.
When complete pasting scrolled backwards and clicked on first ticker sheet and stopped recording the macro.

Then Ran the macro. Does want I want.

Macro1 result pasted below.


Sub Macro1()
'
' Macro1 Macro
'

'
Range("B1:B366").Select
Application.CutCopyMode = False
Selection.Copy
Sheets("APLLTD.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("BIRLACOT.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("CCCL.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("CENTENKA.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("DCM.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("DEEPAKFER.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("FINPIPE.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("GNFC.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("HEXAWARE.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("HINDCOPPE.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("IDEA.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("JAYBARMAR.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("JKAGRI.BO").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("JKTYRE.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("KIRLPNU.BO").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("LML.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("NAGAROIL.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("OSWALAGRO.BO").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("PIRGLASS.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("PIRPHYTO.BO").Select
Range("H2").Select
ActiveSheet.Paste
ActiveWindow.ScrollWorkbookTabs Sheets:=1
ActiveWindow.ScrollWorkbookTabs Sheets:=8
Sheets("RCOM.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("ROLTA.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("SWISSGLA.BO").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("TRENDELEC.BO").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("VALUEIND.NS").Select
Range("H2").Select
ActiveSheet.Paste
Sheets("VIDEOIND.NS").Select
Range("H2").Select
ActiveSheet.Paste
ActiveWindow.ScrollWorkbookTabs Position:=xlFirst
Sheets("APLLTD.NS").Select
End Sub



I still have to do record macro for the second part.

HTH

Thanks.

[jolivanes]

Sorry for the delay. I was otherwise occupied.


Maybe try this on copies of your workbooks.





Sub Maybe()
Dim j As Long, wb1 As Workbook, wb2 As Workbook
Set wb1 = Workbooks("CurrencyEXG.xlsm") '<---- Change file extension if different
On Error Resume Next
Set wb2 = Workbooks("Tickers.xlsm") '<---- Change file extension if different
If wb2 Is Nothing Then MsgBox "Open Ticker.xlsm first.": Exit Sub


wb2.Activate


With wb2.Sheets(2).Range("H3:H28") '<---- Change cell references as required
.Value = wb1.Sheets("Data").Range("B5:B30").Value '<---- Change cell references as required
.Offset(, 1).Formula = "=RC[-2]*RC[-1]"
End With

With Sheets(2).Range("H3")
.Offset(-1).Value = "USDCURR"
.Offset(-1, 1).Value = "Price"
End With

For j = 3 To 10 '<---- Change the 10 to the last sheet index number
Sheets(j).Range("H2:I28").Value = Sheets(2).Range("H2:I28").Value '<---- Change cell references as required
Next j
End Sub

[snb]

Did you ever take a course on Excel or VBA before you started to work with it ? Looks rather sensible to me at least.

[jolivanes]

Never ever did.
Do me/us a favour and give us proper code

[aacod]

Hi jolivanes,

GREAT this works PERFECT.

I would appreciate if you can make the following changes:

1. Copied Data from cells A6:B370 from sheet named ‘DATA’ in WB 'CurrencyEXG', be pasted to sheet(s) in WB named ‘Tickers”, starting from Sheet 2 and stopping before sheet tab named ‘Open Price' on 'Tickers' WB ( depending on what I select, there may be 5 or 50 or 100 sheet tabs between Tab 2 and tab named 'Open Price' on WB 'Tickers' .

2. Round values under column I from cells I3:I370 to 2 decimals on all sheets on WB 'Tickers' which represents price in USD.

Thanks.

aacod

[jolivanes]

As the gentleman in Post#5 alluded to, not a very sophisticated piece of code but we'll wait for him
to supply you with a robust and understandable macro.
The reason I say "understandable" is because you want to be able to change it to your needs, now and later on.



Sub Maybe()
Dim j As Long, wb1 As Workbook, wb2 As Workbook
Set wb1 = Workbooks("CurrencyEXG.xlsm")
On Error Resume Next
Set wb2 = Workbooks("Tickers.xlsm")
If wb2 Is Nothing Then MsgBox "Open Ticker.xlsm first.": Exit Sub
On Error GoTo 0


wb2.Activate
With Sheets(2)
.Range("G3:H367").Value = wb1.Sheets("Data").Range("A6:B370").Value
.Range("H2:I2").Value = Array("USDCURR", "Price")
With Sheets(2).Range("H3:H367").Offset(, 1)
.Formula = "=ROUND(RC[-2]*RC[-1], 2)"
.Value = .Value
End With
End With



For j = 3 To ActiveWorkbook.Sheets("Open Price").Index - 1
Sheets(j).Range("G2:I367").Value = Sheets(2).Range("G2:I367").Value
Next j
End Sub

[aacod]

Hi jolivanes,

The code works but due to my lack of explaining following needs to be corrected, sorry for the confusion:

Copied cells from sheet named ‘DATA’ on WB ‘CurrencyEXG’ should be from B6:B370 and should get pasted under column H on WB ‘Tickers’ from cells H3 below, I was able to correct this.

The result in column ‘I’ on WB ‘Tickers’ from cell I3 copied below to cell I370 under header ‘Price’ is G3*H3. This result must be rounded to 2 decimals. Right now the result under column ‘I’ is the same on all Tabs on WB ‘Tickers’.

Pasting does 'STOP' prior to 'Open Price' tab, which is fantastic.

aacod

[jolivanes]

Like this?



Sub Maybe_This()
Dim j As Long, wb1 As Workbook, wb2 As Workbook
Set wb1 = Workbooks("CurrencyEXG.xlsm")
On Error Resume Next
Set wb2 = Workbooks("Tickers.xlsm")
If wb2 Is Nothing Then MsgBox "Open Ticker.xlsm first.": Exit Sub
On Error GoTo 0
wb2.Activate
For j = 2 To ActiveWorkbook.Sheets("Open Price").Index - 1
With Sheets(j)
.Range("H2:I2").Value = Array("USDCURR", "Price")
.Range("H3:H367").Value = wb1.Sheets("Data").Range("B6:B370").Value
.Range("H3:H367").Offset(, 1).Formula = "=ROUND(RC[-2]*RC[-1], 2)"
.Range("H3:H367").Offset(, 1).Value = .Range("H3:H367").Offset(, 1).Value
End With
Next j
End Sub

[aacod]

Hi jolivanes,

Incredibly Phenomenal, you have made the code work the way I wanted. Appreciate it. I may come back to you on the same if I have some more ideas to add to the code.

Thanks.

aacod

[jolivanes]

Glad to hear that it does what you want it to.
Good luck

[aacod]

Hi jolivanes,

Need to add following as continuation after the previous code executes:

In WB named ‘Tickers’, create new sheet as Tab 2 named ‘SCRIPS’.

In WB named ‘Tickers’ from existing Tab 1 named ‘Parameters’, copy contents from A12:A320 and paste on to the newly created sheet named ‘SCRIPS’ from cell A3 down, naming Header in A2 as ‘Scrip Name’ and auto adjust the column width to fit the contents pasted.

On newly created sheet named ‘SCRIPS’ create headers as ‘Min Price USD’, ‘Max Price USD’ and ‘AVERAGE Price USD’ In cell B2, C2 and D2 respectively.

On newly created sheet named ‘SCRIPS’, copy and paste the minimum and maximum price in cells B3 and C3 respectively from tab 3 looking to cells I3:I320 respectively. In D3 put the average price from cells I3:I320 from Tab 3 neglecting values ‘0 ’ from cells I3:I320 from Tab 3.

Repeat copy and paste for minimum, maximum and average price on Sheet named ‘SCRIPS’ from all the tabs from Column I3:I320 as above starting from tab 3 and ending prior to tab named ‘open price’.

Thanks.

aacod



SCRIPS




A
B
C
D


1






2
Scrip Name
Min Price USD
Max Price USD
Average Price USD


3
ACC.NS
0
0
#DIV/0!


4






5






6






7









Spreadsheet Formulas




Cell
Formula


B3
=MIN(A3:A320)


C3
=MAX(A3:A320)


D3
=AVERAGE(A3:A320)







Excel tables to the web >> Excel Jeanie HTML 4 (http://www.excel-jeanie-html.de/index.php?f=1)

[jolivanes]

How far do you get with this?

Sub Maybe_This()
Dim j As Long, wb1 As Workbook, wb2 As Workbook, lr As Long, i As Long
Application.ScreenUpdating = False
Set wb1 = Workbooks("VB Copy Between Workbooks And Add Formulae (CurrencyEXG).xlsm")
lr = Cells(Rows.Count, 2).End(xlUp).Row
On Error Resume Next
Set wb2 = Workbooks("VB Copy Between Workbooks And Add Formulae (Tickers).xlsm")
If wb2 Is Nothing Then MsgBox "Open the Ticker workbook first.": Exit Sub
On Error GoTo 0
wb2.Activate
For j = 2 To ActiveWorkbook.Sheets("Open Price").Index - 1
With Sheets(j)
.Range("H2:I2").Value = Array("USDCURR", "Price")
.Range("H3:H367").Value = wb1.Sheets("Data").Range("B6:B370").Value
.Range("H3:H367").Offset(, 1).Formula = "=ROUND(RC[-2]*RC[-1], 2)"
.Range("H3:H367").Offset(, 1).Value = .Range("H3:H367").Offset(, 1).Value
End With
Next j
ActiveWorkbook.Sheets.Add After:=Sheets(1)
ActiveSheet.Name = "SCRIPS"
With ActiveSheet
.Range("A2:D2").Value = Array("Scrip Name", "Min Price USD", "Max Price USD", "Average Price USD")
.Range("A3:A311").Value = Sheets(1).Range("A12:A320").Value
For i = 3 To ActiveWorkbook.Sheets("Open Price").Index - 1
.Cells(i, 2).Value = WorksheetFunction.Min(Sheets(i).Range("I3:I320"))
.Cells(i, 3).Value = WorksheetFunction.Max(Sheets(i).Range("I3:I320"))
.Cells(i, 4).Value = WorksheetFunction.Average(Sheets(i).Range("I3:I320"))
Next i
.Columns("A:D").AutoFit
End With
Application.ScreenUpdating = True
End Sub

[aacod]

Hi jolivanes,

On running the code it stops at the following line, giving a Run time Error 9, Subscript out of range, End, Debug:
Set wb1 = Workbooks("VB Copy Between Workbooks And Add Formulae (CurrencyEXG).xlsm")

aacod

[jolivanes]

Sorry. That is the testing name.
Change that to

Set wb1 = Workbooks("CurrencyEXG.xlsm")
and change

Set wb2 = Workbooks("VB Copy Between Workbooks And Add Formulae (Tickers).xlsm")
to

Set wb2 = Workbooks("Tickers.xlsm")

[aacod]

Hi jolivanes

It does work perfect :clap: except requires a little fine tuning as follows:

1. In column B on SCRIPS tab....under Min Price USD, it puts zeros form cells B3 below instead of neglecting zeros and picking the minimum lowest value from Column I from each tabs.
2. The figures in column D on SCRIPS tab must round off to two decimals. Please See below.

Thanks

aacod.


Current Result as follows:
SCRIPS




A
B
C
D


1






2
Scrip Name
Min Price USD
Max Price USD
Average Price USD


3
BHEL.NS
0
4.71
2.904811321


4
GNFC.NS
0
1.81
1.141981132


5
HINDCOPPE.NS
0
2.02
1.093993711


6
LT.NS
0
29.5
19.07166667


7
RELIANCE.NS
0
19.39
12.84113208


8
SIEMENS.NS
0
16.53
10.7072327


9








Excel tables to the web >> Excel Jeanie HTML 4 (http://www.excel-jeanie-html.de/index.php?f=1)

Need Final as follows:
SCRIPS




A
B
C
D


1






2
Scrip Name
Min Price USD
Max Price USD
Average Price USD


3
BHEL.NS
0.15
4.71
2.90


4
GNFC.NS
1.00
1.81
1.14


5
HINDCOPPE.NS
1.75
2.02
1.09


6
LT.NS
28.0
29.5
19.07


7
RELIANCE.NS
15.25
19.39
12.84


8
SIEMENS.NS
14.70
16.53
10.70


9








Excel tables to the web >> Excel Jeanie HTML 4 (http://www.excel-jeanie-html.de/index.php?f=1)

Thanks

aacod.

[jolivanes]

Instead of me guessing, maybe attach a couple of samples.

[jolivanes]

Regarding your pm.
Please attach sanitized copies of the workbooks here so everyone that wants/needs to can have a look at them.
They don't need to be the full workbooks (size problems?) but they need to be representative of what you're working with.

[jolivanes]

Maybe this will work?

Sub Maybe_This()
Dim j As Long, wb1 As Workbook, wb2 As Workbook, lr As Long, i As Long
Application.ScreenUpdating = False
Set wb1 = Workbooks("CurrencyEXG.xlsm") '<---- Check if WB Name is right
lr = Cells(Rows.Count, 2).End(xlUp).Row
On Error Resume Next
Set wb2 = Workbooks("Tickers.xlsm") '<---- Check if WB Name is right
If wb2 Is Nothing Then MsgBox "Open the Ticker workbook first.": Exit Sub
On Error GoTo 0
wb2.Activate
For j = 2 To ActiveWorkbook.Sheets("Open Price").Index - 1
With Sheets(j)
.Range("H2:I2").Value = Array("USDCURR", "Price")
.Range("H3:H367").Value = wb1.Sheets("Data").Range("B6:B370").Value
.Range("H3:H367").Offset(, 1).Formula = "=ROUND(RC[-2]*RC[-1], 2)"
.Range("H3:H367").Offset(, 1).Value = .Range("H3:H367").Offset(, 1).Value
End With
Next j
ActiveWorkbook.Sheets.Add After:=Sheets(1)
ActiveSheet.Name = "SCRIPS"
With ActiveSheet
.Range("A2:D2").Value = Array("Scrip Name", "Min Price USD", "Max Price USD", "Average Price USD")
.Range("A3:A311").Value = Sheets(1).Range("A12:A320").Value
For i = 3 To ActiveWorkbook.Sheets("Open Price").Index - 1
.Cells(i, 2).Value = WorksheetFunction.Small(Sheets(i).Range("I3:I320"), 1 + WorksheetFunction.CountIf(Sheets(i).Range("I3:I320"), -1)) '<---- Changed
.Cells(i, 3).Value = WorksheetFunction.Max(Sheets(i).Range("I3:I320"))
.Cells(i, 4).Value = WorksheetFunction.Average(Sheets(i).Range("I3:I320"))
Next i
.Range("B3:D320").NumberFormat = "0.00"
.Columns("A:D").AutoFit
End With
Application.ScreenUpdating = True
End Sub

[aacod]

Hi jolivanes,

Sorry for the previous post which does not make sense.

I have posted the real results below that I would like to achieve when the later part of the macro is executed.

In the example posted below, 'Min Price USD' 2.37 is actual for the scrip from the sheet named BHEL.NS and 1.07 from sheet GSFC.NS respectively. There may be a value of zero under the range when there is a holiday and no trading is done, so zero values must be neglected.

The values under column C 'Max Price USD' for BHEL.NS 4.71 and 1.81 for GSFC.NS resp. are actual.

Under column D the Average price USD should be eqivalent to values under column E which are correct values when zeros are discarded/neglected on sheet(s) BHEL.NS and GSFC.NS resp.

The current values that are picked up under column D 'Average Price USD' on running the macro are incorrect because values of zero are picked up for scrips from respective tabs.

Thanks

aacod



SCRIPS




A
B
C
D
E


1

ACTUAL



Actual



2
Scrip Name
Min Price USD
Max Price USD
Average Price USD
Average


3
BHEL.NS
2.37
4.71
2.90
3.54


4
GNFC.NS
1.07
1.81
1.14
1.44


5
HINDCOPPE.NS
0.93
2.02
1.09
1.475


6
LT.NS
15.34
29.5
19.07
22.42


7
RELIANCE.NS
12.84
19.39
12.84
16.115


8
SIEMENS.NS
8.32
16.53
10.71
12.425


9










Spreadsheet Formulas




Cell
Formula


E3
=AVERAGE(B3:C3)


E4
=AVERAGE(B4:C4)


E5
=AVERAGE(B5:C5)


E6
=AVERAGE(B6:C6)


E7
=AVERAGE(B7:C7)


E8
=AVERAGE(B8:C8)







Excel tables to the web >> Excel Jeanie HTML 4 (http://www.excel-jeanie-html.de/index.php?f=1)

[jolivanes]

See Post #18

[aacod]

Hi jolivanes,

Unfortunately I did not see your post # 20 before posting my post #21.

Anyways I tried the code from post 20 and still gives me value of zero for Min Price USD.

I have attached Book1 with 2 actual sheets for BHEL.NS and GSFC.NS for your review.

Jan 14, 1014 was a holiday for the stock exchange and so no trading occurred, hence value zero on that day. I want the zero value(s) to be neglected from Column 'I' for Min Price USD and a value a value of 2.37 inserted which is the next minimum after zero for BHEL.NS and and 1.07 for GSFC.NS resp.

HTH

aacod

[jolivanes]

I assume that the attached in Post #23 represents your "Tickers" workbook. Right?

[aacod]

Hi jolivanes,

Yes, they are 2 sheets from 'Tickers' WB, sheet # 2 and sheet # 3.

aacod

[jolivanes]

Try this.

Sub Maybe_This()
Dim j As Long, wb1 As Workbook, wb2 As Workbook, lr As Long, i As Long
Application.ScreenUpdating = False
Set wb1 = Workbooks("CurrencyEXG.xlsm")
lr = Cells(Rows.Count, 2).End(xlUp).Row
On Error Resume Next
Set wb2 = Workbooks("Tickers.xlsm")
If wb2 Is Nothing Then MsgBox "Open the Ticker workbook first.": Exit Sub
On Error GoTo 0
wb2.Activate
For j = 2 To ActiveWorkbook.Sheets("Open Price").Index - 1
With Sheets(j)
.Range("H2:I2").Value = Array("USDCURR", "Price")
.Range("H3:H367").Value = wb1.Sheets("Data").Range("B6:B370").Value
.Range("H3:H367").Offset(, 1).Formula = "=ROUND(RC[-2]*RC[-1], 2)"
.Range("H3:H367").Offset(, 1).Value = .Range("H3:H367").Offset(, 1).Value
End With
Next j
ActiveWorkbook.Sheets.Add After:=Sheets(1)
ActiveSheet.Name = "SCRIPS"
With ActiveSheet
.Range("A2:E2").Value = Array("Scrip Name", "Min Price USD", "Max Price USD", "Average Price USD", "Actual Average")
.Range("A3:A311").Value = Sheets(1).Range("A12:A320").Value
For i = 3 To ActiveWorkbook.Sheets("Open Price").Index - 1
.Cells(i, 2).Formula = "=Small(" & Sheets(i).Name & "!I3:I320, CountIf(" & Sheets(i).Name & "!I3:I320,0) + 1)"
.Cells(i, 2).Value = .Cells(i, 2).Value '<---- Optional
.Cells(i, 3).Value = WorksheetFunction.Max(Sheets(i).Range("I3:I320"))
.Cells(i, 4).Value = WorksheetFunction.Average(Sheets(i).Range("I3:I320"))
.Cells(i, 5).Value = (.Cells(i, 2).Value + .Cells(i, 3).Value) / 2
Next i
.Range("B3:E320").NumberFormat = "0.00"
.Columns("A:E").AutoFit
End With
Application.ScreenUpdating = True
End Sub

[aacod]

Hi jolivanes,

GREAT, FABULOUS, :cool: & :thumb. :clap::clap::clap::clap::clap:.

I could achieve what I wanted with your expertize and help.Thanks.

aacod