I am trying to flag records where a condition is met and am getting 'almost' answers. There is a column with - and + values. The code will iterate until sum = 2000 OR (sum>=2000 and next record is positive) - so the last consecutive negative record that >= 2000 will get flagged. Code below does not wait until the end of the last negative number (i.e, 30 records in a row with - number). Any thoughts on fixing?
Dim homecell As Range
Set homecell = Range("I1")
Set homecell = Range("A1").EntireRow.Find("2k Flag")
homecell.Select
homecell.EntireColumn.ClearContents
homecell = "2k Flag"
Dim i As Long
i = 1
Dim a As Long
a = 0
Dim pos As Boolean
Dim sum As Double
Dim sfrom As Double
sfrom = 1
i = 1
Dim wforp As Boolean
Do Until sfrom > Range("A1").End(xlDown).Row
If Range("A1").Offset(sfrom, 0) = Range("A1").Offset(sfrom + a, 0) Then
Do Until a = 2000 Or (sum <= -200 And pos = False) Or pos = True
sum = sum + homecell.Offset(sfrom + a, -1)
If homecell.Offset(sfrom + a, -1) > 0 Then
pos = True
wforp = False
End If
a = a + 1
Loop
If pos = False And sum <= -200 And wforp = False Then
homecell.Offset(sfrom + a - 1, 0) = "yes"
wforp = True
sfrom = sfrom + a - 1
End If
sum = 0
pos = False
a = 0
Else
wforp = False
End If
sfrom = sfrom + 1
Loop
Change the line
Do Until a = 2000 Or (sumneg <= -200 And pos = False) Or pos = True
to
Do Until a = 2000 Or (sumneg <= -2000 And pos = False) Or pos = True
i.e. sumneg <= -2000
Note that I have changed your variable 'sum' to 'sumneg' to avoid any confusion with the VBA reserved keyword.
Might be a good idea and give you more flexibility to declare this value as a variable itself.
Wasn't quite sure about flagging the last value in the group but if you do want this then replace
sfrom = sfrom + a - 1
with the following code:
sfrom = (sfrom + a - 1) + 1
Do While homecell.Offset(sfrom, -1) < 0
sfrom = sfrom + 1
Loop
homecell.Offset(sfrom - 1, 0) = "last neg in group"
Related
The code is working for 3 times in Excel VBA but at the forth time it gives an error. When I put a toggle point there, the code cannot pass "Duration = Duration + drtn" and "Type MisMatch" error shows up. Is there any way to fix the code?
Function simul(t)
Dim wk As Worksheet
Set wk = Worksheets("Simulation")
Dim FoundCell As Range
Duration = 0
i = 1
char = "StartStep"
drtn = 0
While i = 1
m = WorksheetFunction.CountIf(Range("A2:A30"), char)
Set FoundCell = wk.Range("A:A").Find(char)
x = FoundCell.Row
y = FoundCell.Row
Dim myarray() As Variant
ReDim myarray(m)
For j = 0 To m - 1
myarray(j) = wk.Range("E" & x)
x = x + 1
Next
If char = "A" Then
drtn = Application.Evaluate("LOGNORM.INV(RAND(),r5,r6)")
ElseIf char = "B" Then
drtn = Application.Evaluate("ABS(NtLogisticInv(RAND(),r29,r30)")
ElseIf char = "C" Then
drtn = Application.Evaluate("r17*(-LN(1-RAND()))^(1/r18)")
Else
i = 0
drtn = 0
End If
Duration = Duration + drtn
r = Rnd()
k = 0
While r > myarray(k)
k = k + 1
Wend
char = wk.Range("B" & y + k)
Wend
wk.Range("U" & t) = Duration
End Function
I need help in Vb.net, how can I traverse through an 8 digit integer and check whether
Three numbers r repeated consecutively like 111,222
Check whether numbers are consecutively spaced like 123,876 3. Check whether 4 numbers r present
I input the 8 digit as string as its a requirement then convert into a string.
Imports System.console
Public Class residentNumberCheck
Dim cardNumber As String
Public Sub inputNumberAndCheck()
writeline("Enter the 8 Digit Resident Card Number")
cardNumber = readline()
While (cardNumber.length() <> 8)
writeline("The Resident Card Number is Invalid. It does not contain 8 digits... Please enter again")
cardNumber = readline()
End While
End Sub
Public Sub sameThreeNumber()
writeline("")
writeline("...Checking for 3 consecutive numbers...")
writeline("")
Dim Num As Integer = Integer.parse(cardNumber)
Dim temp As Integer = Num
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim checker As Boolean = False
While (Num > 0)
i = Num Mod 10
Num = Num \ 10
j = Num Mod 10
temp = temp \ 10
k = temp Mod 10
Num = temp \ 10
temp = Num \ 10
If (i = j And j = k) Then
writeline(" ****The Number is a Special Number as the Number {0} occurs three consecutive times****", i)
checker = True
Return
End If
End While
If (checker = False) Then
writeline("The Number does not have 3 consecutive numbers")
End If
End Sub
Public Sub ConsecutiveNumber()
writeline("")
writeline("...Checking for consecutive digits in increasing or decreasing...")
writeline("")
Dim Num As Integer = Integer.parse(cardNumber)
Dim temp As Integer = Num
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim checker As Boolean = False
While (Num > 0)
i = Num Mod 10
Num = Num \ 10
j = Num Mod 10
temp = temp \ 10
k = temp Mod 10
Num = temp \ 10
temp = Num \ 10
check1:
If (i = j + 1) Then
If (j = k + 1) Then
checker = True
writeline(" ****The Number is a Special Number as it has {0}, {1}, {2} consecutive numbers****", k, j, i)
Return
End If
End If
check2:
If (i = j - 1) Then
If (j = k - 1) Then
checker = True
writeline(" ****The Number is a Special Number as it has {0}, {1}, {2} consecutive numbers****", k, j, i)
Return
End If
End If
End While
If (checker = False) Then
writeline("The Number does not contain consecutive digits in increasing or decreasing")
End If
End Sub
Public Sub checksimilarfourdigits()
writeline("")
writeline("...Checking if a number is repeated four times...")
writeline("")
Dim Num As Integer = Integer.parse(cardNumber)
Dim temp As Integer
Dim x As Integer
Dim y As Integer
Dim i As Integer
Dim j As Integer
Dim counter As Integer = 0
Dim checker As Boolean = False
While (Num > 0)
logic:
i = Num Mod 10
Num = Num \ 10
j = Num Mod 10
Num = Num \ 10
check:
If (i = j) Then
counter = counter + 1
temp = i
Else
temp = j
GoTo logic
End If
If (temp = i) Then
counter = counter + 1
x = temp
y = 0
End If
If (temp = j) Then
counter = counter + 1
y = temp
x = 0
End If
If (counter >= 4) Then
If (x = 0) Then
writeline(" ****The Number is a Special Number as the number {0} repeats four times or more****", y)
checker = True
Return
End If
If (y = 0) Then
writeline(" ****The Number is a Special Number as the number {0} repeats four times or more****", x)
checker = True
Return
End If
End If
End While
If (checker = False) Then
writeline("The Number does not contain 4 equal digits")
End If
End Sub
Public Shared Sub main()
Dim user As residentNumberCheck = New residentNumberCheck()
user.inputNumberAndCheck()
user.sameThreeNumber()
user.ConsecutiveNumber()
user.checksimilarfourdigits()
End Sub
End Class
If you want to compact your code you may use Regex class:
Dim cardNumber As String = TextBox1.Text
' (\d) finds digit (\d)\1 finds digit repeated once, here \1 makes
' reference to first group (), this is, (\d)
' (\d)\1{2,} finds digit repeated at least 2 times
Dim mc As MatchCollection = New Regex("(\d)\1{2,}").Matches(cardNumber)
If mc.Count Then ' there are at least 3 consecutive equal #s
Trace.WriteLine(String.Format("Number {0} occurs {1} times", mc(0).Value, mc(0).Value.Length))
End If
mc = New Regex("\d").Matches(cardNumber)
' each mc() contains one digit
Dim incr As Int32=0, indI As Int32 = -1
Dim decr As Int32=0, indD As Int32 = -1
For i As Int32 = 0 To mc.Count - 1
Dim curr As Int32 = Int32.Parse(mc(i).Value)
If i < mc.Count - 1 Then ' there is a next number
' if current+1=next# =>increment count & save index
If curr + 1 = Int32.Parse(mc(i + 1).Value) Then
If indI = -1 Then indI = i
incr += 1 : If incr = 2 Then Exit For
Else
incr = 0 : indI = -1
End If
End If
If i Then ' there is a previous #
' if current+1=previous# =>previous incr. count & save index
If curr + 1 = Int32.Parse(mc(i - 1).Value) Then
If indD = -1 Then indD = i
decr += 1 : If decr = 2 Then Exit For
Else
decr = 0 : indD = -1
End If
End If
Next
If incr = 2 Then
Trace.WriteLine(String.Format("{0}{1}{2} Consecutive numbers", mc(indI), mc(indI + 1), mc(indI + 2)))
ElseIf decr = 2 Then
Trace.WriteLine(String.Format("{0}{1}{2} Consecutive numbers", mc(indD - 1), mc(indD), mc(indD + 1)))
End If
I am creating an Excel pie and bar charts from exported data pragmatically. Here I need to pick the cell range dynamically. For example, after header name all data should be picked up until cell contains "TOTAL" line.
Below is my current code.
If String.IsNullOrEmpty(HttpContext.Current.Request.QueryString("oversight")) Then 'This is Summary Level
Dim worksheet2 As ExcelWorksheet = pkg.Workbook.Worksheets.Add("Chart - CY Consumable")
worksheet2.DefaultColWidth = 15
Dim consumableChart As OfficeOpenXml.Drawing.Chart.ExcelPieChart = worksheet2.Drawings.AddChart("ConsumableChart", OfficeOpenXml.Drawing.Chart.eChartType.Pie)
Dim r1, r2 As ExcelRange
r1 = worksheet.Cells("A6:A12") // here I want it to be selected dynamically after header and before the total line
r2 = worksheet.Cells("B6:B12")
consumableChart.Series.Add(r2, r1)
consumableChart.Style = OfficeOpenXml.Drawing.Chart.eChartStyle.Style2
consumableChart.Title.Text = "FY 2018 Consumable by Regional & Central Oversight Programs"
consumableChart.Legend.Remove()
consumableChart.SetPosition(1, 1, 1, 1)
consumableChart.SetSize(1040, 880)
consumableChart.DataLabel.ShowLeaderLines = True
consumableChart.DataLabel.ShowCategory = True
consumableChart.DataLabel.ShowPercent = True
Thanks in advance.
Dim totalRow As Integer
If ds.Tables.Count > 0 Then
Dim k As Integer = 0
For j As Integer = 0 To ds.Tables(0).Columns.Count - 1
If Not skip.Contains(j) Then
If columnNames.Count > 0 AndAlso columnNames.Count = (ds.Tables(0).Columns.Count - skip.Count) Then
strTitle = columnNames(k)
Else
strTitle = ds.Tables(0).Columns(j).ColumnName.Replace("_", " ")
End If
worksheet.Cells(p, k + 1).Value = strTitle
k = k + 1
End If
Next
Dim i As Integer = p + 1
For Each r As DataRow In ds.Tables(0).Rows
If includeTotals OrElse (Not r.Item(2).ToString().Trim().ToUpper().StartsWith("TOTAL") AndAlso _
Not r.Item(2).ToString().Trim().ToUpper().StartsWith("SUBTOTAL") AndAlso _
Not r.Item(2).ToString().Trim().ToUpper().StartsWith("TOTAL") AndAlso _
Not r.Item(2).ToString().Trim().ToUpper().StartsWith("SUBTOTAL")) Then
k = 0
For j As Integer = 0 To ds.Tables(0).Columns.Count - 1
If Not skip.Contains(j) Then
If r.Item(j) Is DBNull.Value Then
worksheet.Cells(i, k + 1).Value = ""
Else
If k = 0 Then
worksheet.Cells(i, k + 1).Style.Numberformat.Format = "#"
worksheet.Cells(i, k + 1).Value = r.Item(j).ToString()
Else
worksheet.Cells(i, k + 1).Value = r.Item(j)
End If
End If
// Checking if it is first col last row
If r.Item(j).ToString().Contains("TOTAL") Then
totalRow = i
End If
If r.Item(j).GetType().Name = "Decimal" Then
If roundUp Then
If useParens Then
worksheet.Cells(i, k + 1).StyleID = 2
Else
worksheet.Cells(i, k + 1).StyleID = 2 '4
End If
Else
If useParens Then
worksheet.Cells(i, k + 1).StyleID = 1
Else
worksheet.Cells(i, k + 1).StyleID = 1 '3
End If
End If
End If
k = k + 1
End If
Next
i = i + 1
End If
Next
End If
If String.IsNullOrEmpty(HttpContext.Current.Request.QueryString("oversight")) Then 'This is Summary Level
Dim worksheet2 As ExcelWorksheet = pkg.Workbook.Worksheets.Add("Chart - CY Consumable")
worksheet2.DefaultColWidth = 15
// showing the criteria
p = 1
If includeCriteria Then
Try
Dim reportTitle As String = String.Empty
reportTitle = "Central/Regional Oversight Programs"
Dim sb As StringBuilder = New StringBuilder()
sb.Append(reportTitle)
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
sb.Append("Budget Fiscal Year : ")
sb.Append(HttpContext.Current.Session("bfy"))
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
sb.Append("Currently viewing transactions from inception through ")
Dim fm As Integer = CInt(HttpContext.Current.Session("fm"))
If fm < 4 Then
sb.Append(MonthName(fm + 9))
sb.Append(" ")
sb.Append(CInt(HttpContext.Current.Session("fy")) - 1)
Else
sb.Append(MonthName(fm - 3))
sb.Append(" ")
sb.Append(HttpContext.Current.Session("fy"))
End If
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
If String.IsNullOrEmpty(HttpContext.Current.Request.QueryString("division")) Then
sb.Append("Fund Center(s) : ALL")
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
Else
sb.Append("Fund Center(s) : ")
sb.Append(HttpContext.Current.Request.QueryString("division"))
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
End If
If String.IsNullOrEmpty(HttpContext.Current.Request.QueryString("fa5")) Then
sb.Append("Func Area 5 : ALL")
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
Else
sb.Append("Func Area 5 : ")
sb.Append(HttpContext.Current.Request.QueryString("fa5"))
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
End If
If Not String.IsNullOrEmpty(HttpContext.Current.Request.QueryString("oversight")) Then
sb.Append("Oversight Program - ")
sb.Append(HttpContext.Current.Request.QueryString("oversight"))
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
End If
sb.Append("FBMS data as of ")
sb.Append(HttpContext.Current.Application("lastUpdated_BIA"))
sb.Append(" at close of business.")
worksheet2.Cells(p, 1).Value = sb.ToString()
sb.Length = 0
p = p + 1
worksheet2.Cells(p, 1).Value = ""
p = p + 1
Catch ex As Exception
For r As Integer = 1 To p - 1
worksheet2.DeleteRow(1, True)
Next
p = 1
End Try
End If
//create chart in new tab
Dim consumableChart As OfficeOpenXml.Drawing.Chart.ExcelPieChart = worksheet2.Drawings.AddChart("ConsumableChart", OfficeOpenXml.Drawing.Chart.eChartType.Pie)
Dim r1, r2 As ExcelRange
// setting the value to check the last row
Dim startColumn As String = "A"
Dim endColumn As String = "B"
Dim startIndex As Integer = 8 // Index where to start
Dim endIndex As Integer = totalRow - 1 'this is determined based on the TOTAL Line from above code
// checking and setting the values and label of pie chart
r1 = worksheet.Cells(String.Concat(startColumn, startIndex.ToString(), ":", startColumn, endIndex))
r2 = worksheet.Cells(String.Concat(endColumn, startIndex.ToString(), ":", endColumn, endIndex))
consumableChart.Series.Add(r2, r1)
consumableChart.Style = OfficeOpenXml.Drawing.Chart.eChartStyle.Style2
consumableChart.Title.Text = "FY 2018 Consumable by Regional & Central Oversight Programs"
consumableChart.Legend.Remove()
consumableChart.SetPosition(5, 5, 5, 5)
consumableChart.SetSize(1040, 880)
consumableChart.DataLabel.ShowLeaderLines = True
consumableChart.DataLabel.ShowCategory = True
consumableChart.DataLabel.ShowPercent = True
I have a problem when I want to build a pairs trading automation using Excel VBA.
My strategy is to open a position (OTC_Sell or OTC_Buy) when the spreads of two stocks hit +/- 2 standard deviation, and to close a position (CTC_buy or CTC_sell) when the spreads of two stocks hit +/- 4 standard deviation or hit back to the mean. Once the position is closed, I can open another position once I received another open trade condition(OTC).
However, when I run the code, it seems that the loop only runs one time since I can only get one trade (highlighted in yellow).After this cell, I can only get zeros but no other trade signals. I re-run the code starting from that cell beside the original column and get another trade (highlighted in green).still, I get all zeros afterwards. Whereas I want to get all trade signals within one column.
Function SignalCTC(Price1, Price2, Mean, SD, StopLoss)
Dim i, j, k, m, n, o, p, numRows, numOTC, order, list, flag, finish
numRows = Price1.Rows.Count
Dim SignalColOTC()
ReDim SignalColOTC(numRows, 1)
Dim Price1Col()
ReDim Price1Col(numRows)
Dim Price2Col()
ReDim Price2Col(numRows)
Dim P_Ratio()
ReDim P_Ratio(numRows)
'Loop 1
For i = 1 To numRows
P_Ratio(i) = Price1(i) / Price2(i)
Next i
UpperLim = Mean + (2 * SD)
LowerLim = Mean - (2 * SD)
Count = 0
flag = 0
For i = 1 To numRows
If (Count = 0 And (P_Ratio(i) < UpperLim) And (P_Ratio(i) > LowerLim)) Then
Count = 0
flag = 0
SignalColOTC(i, 1) = "Wait&See"
ElseIf (Count = 0 And (P_Ratio(i) > UpperLim)) Then
Count = 1
flag = 1
SignalColOTC(i, 1) = "Wait&See"
ElseIf (Count = 0 And (P_Ratio(i) < LowerLim)) Then
Count = 1
flag = -1
SignalColOTC(i, 1) = "Wait&See"
ElseIf (Count = 1 And flag = 1 And (P_Ratio(i) < UpperLim) And (P_Ratio(i) > Mean)) Then
Count = 0
flag = 0
SignalColOTC(i, 1) = "OTC_Sell"
ElseIf (Count = 1 And flag = -1 And (P_Ratio(i) > LowerLim) And (P_Ratio(i) < Mean)) Then
Count = 0
flag = 0
SignalColOTC(i, 1) = "OTC_Buy"
Else: SignalColOTC(i, 1) = "Wait&See"
End If
Next i
numOTC = 0
order = 0
list = 0
For i = 1 To numRows
If (SignalColOTC(i, 1) = "OTC_Sell") Or (SignalColOTC(i, 1) = "OTC_Buy") Then
numOTC = numOTC + 1
Else: numOTC = numOTC
End If
Next i
'Dim x
'Loop 2
Dim SignalColCTC()
ReDim SignalColCTC(numRows, numOTC)
For n = 1 To numRows
If (SignalColOTC(n, 1) = "OTC_Sell") Then
list = list + 1
SignalColCTC(n, list) = "OTC_Sell"
For j = n + 1 To numRows
If ((P_Ratio(j) < Mean) Or (Abs(P_Ratio(j)) > (1 + StopLoss) * Abs(P_Ratio(n)))) Then
SignalColCTC(j, list) = "CTC_Buy"
Else: SignalColCTC(j, list) = "Wait&See"
End If
Next j
ElseIf (SignalColOTC(n, 1) = "OTC_Buy") Then
list = list + 1
SignalColCTC(n, list) = "OTC_Buy"
For k = n + 1 To numRows
If ((P_Ratio(k) > Mean) Or (Abs(P_Ratio(k)) < (1 - StopLoss) * Abs(P_Ratio(n)))) Then
SignalColCTC(k, list) = "CTC_Sell"
Else: SignalColCTC(k, list) = "Wait&See"
End If
Next k
End If
Next n
'Loop 3
For o = 1 To numRows
For list = 1 To numOTC
If (SignalColCTC(o, list) = "CTC_Buy") Or (SignalColCTC(o, list) = "CTC_Sell") Then
For p = o + 1 To numRows
SignalColCTC(p, list) = "0"
Next p
End If
Next list
Next o
SignalCTC = SignalColCTC
End Function
Should this be a problem with Loop 3? I tried to put both loop 2 and loop 3 under one loop, but I get not even one trade signal but all zero this time.
Function SignalCTC(Price1, Price2, Mean, SD, StopLoss)
Dim i, j, k, m, n, o, p, numRows, numOTC, order, list, flag, finish
numRows = Price1.Rows.Count
Dim SignalColOTC()
ReDim SignalColOTC(numRows, 1)
Dim Price1Col()
ReDim Price1Col(numRows)
Dim Price2Col()
ReDim Price2Col(numRows)
Dim P_Ratio()
ReDim P_Ratio(numRows)
'Loop 1
For i = 1 To numRows
P_Ratio(i) = Price1(i) / Price2(i)
Next i
UpperLim = Mean + (2 * SD)
LowerLim = Mean - (2 * SD)
Count = 0
flag = 0
For i = 1 To numRows
If (Count = 0 And (P_Ratio(i) < UpperLim) And (P_Ratio(i) > LowerLim)) Then
Count = 0
flag = 0
SignalColOTC(i, 1) = "Wait&See"
ElseIf (Count = 0 And (P_Ratio(i) > UpperLim)) Then
Count = 1
flag = 1
SignalColOTC(i, 1) = "Wait&See"
ElseIf (Count = 0 And (P_Ratio(i) < LowerLim)) Then
Count = 1
flag = -1
SignalColOTC(i, 1) = "Wait&See"
ElseIf (Count = 1 And flag = 1 And (P_Ratio(i) < UpperLim) And (P_Ratio(i) > Mean)) Then
Count = 0
flag = 0
SignalColOTC(i, 1) = "OTC_Sell"
ElseIf (Count = 1 And flag = -1 And (P_Ratio(i) > LowerLim) And (P_Ratio(i) < Mean)) Then
Count = 0
flag = 0
SignalColOTC(i, 1) = "OTC_Buy"
Else: SignalColOTC(i, 1) = "Wait&See"
End If
Next i
numOTC = 0
order = 0
list = 0
For i = 1 To numRows
If (SignalColOTC(i, 1) = "OTC_Sell") Or (SignalColOTC(i, 1) = "OTC_Buy") Then
numOTC = numOTC + 1
Else: numOTC = numOTC
End If
Next i
'Dim x
x=1
For Y=x to numRows
'Loop 2
Dim SignalColCTC()
ReDim SignalColCTC(numRows, numOTC)
For n = x To numRows
If (SignalColOTC(n, 1) = "OTC_Sell") Then
list = list + 1
SignalColCTC(n, list) = "OTC_Sell"
For j = n + 1 To numRows
If ((P_Ratio(j) < Mean) Or (Abs(P_Ratio(j)) > (1 + StopLoss) * Abs(P_Ratio(n)))) Then
SignalColCTC(j, list) = "CTC_Buy"
Else: SignalColCTC(j, list) = "Wait&See"
End If
Next j
ElseIf (SignalColOTC(n, 1) = "OTC_Buy") Then
list = list + 1
SignalColCTC(n, list) = "OTC_Buy"
For k = n + 1 To numRows
If ((P_Ratio(k) > Mean) Or (Abs(P_Ratio(k)) < (1 - StopLoss) * Abs(P_Ratio(n)))) Then
SignalColCTC(k, list) = "CTC_Sell"
Else: SignalColCTC(k, list) = "Wait&See"
End If
Next k
End If
Next n
'Loop 3
For o = x To numRows
For list = 1 To numOTC
If (SignalColCTC(o, list) = "CTC_Buy") Or (SignalColCTC(o, list) = "CTC_Sell") Then
For p = o + 1 To numRows
SignalColCTC(p, list) = "0"
Next p
End If
x = p
Next list
Next o
Next Y
SignalCTC = SignalColCTC
End Function
interesting problem here. had a quick look through your code and nothing jumps out. Loop 3 seems fine to me, and didn't seem critical anyway.
maybe the logic you're implementing isn't quite what you want? I've added my commented version (no real changes except tabbing). might be a good approach for you to do similar to check loop 1 and 2 are doing what you want them to.
also, I assume mean and SD inputs are of the price ratios? why not just work them out in the function?
lastly, make sure when you're declaring variables in future you specify data types. can avoid errors and confusion down the line. e.g. 'dim i as integer'
Function SignalCTC(Price1, Price2, Mean, SD, StopLoss)
Dim i, j, k, m, n, o, p, numRows, numOTC, order, list, flag, finish
numRows = Price1.Rows.Count
Dim SignalColOTC()
ReDim SignalColOTC(numRows, 1)
Dim Price1Col()
ReDim Price1Col(numRows)
Dim Price2Col()
ReDim Price2Col(numRows)
Dim P_Ratio()
ReDim P_Ratio(numRows)
'calculate ratios
For i = 1 To numRows
P_Ratio(i) = Price1(i) / Price2(i)
Next i
UpperLim = Mean + (2 * SD)
LowerLim = Mean - (2 * SD)
Count = 0
flag = 0
'Loop 1
'identify possible opening events
For i = 1 To numRows
'if no events (within limits), reset
If (Count = 0 And (P_Ratio(i) < UpperLim) And (P_Ratio(i) > LowerLim)) Then
Count = 0
flag = 0
SignalColOTC(i, 1) = "Wait&See"
'if exceeds for the first time
ElseIf (Count = 0 And (P_Ratio(i) > UpperLim)) Then
Count = 1
flag = 1
SignalColOTC(i, 1) = "Wait&See"
'if under limit for the first time
ElseIf (Count = 0 And (P_Ratio(i) < LowerLim)) Then
Count = 1
flag = -1
SignalColOTC(i, 1) = "Wait&See"
'if already exceeded once and now within limits
ElseIf (Count = 1 And flag = 1 And (P_Ratio(i) < UpperLim) And (P_Ratio(i) > Mean)) Then
Count = 0
flag = 0
SignalColOTC(i, 1) = "OTC_Sell"
'if were under limit once and now within limits
ElseIf (Count = 1 And flag = -1 And (P_Ratio(i) > LowerLim) And (P_Ratio(i) < Mean)) Then
Count = 0
flag = 0
SignalColOTC(i, 1) = "OTC_Buy"
Else
SignalColOTC(i, 1) = "Wait&See"
End If
Next i
numOTC = 0
order = 0
list = 0
'count opening events
For i = 1 To numRows
If (SignalColOTC(i, 1) = "OTC_Sell") Or (SignalColOTC(i, 1) = "OTC_Buy") Then
numOTC = numOTC + 1
Else
'numOTC = numOTC 'redundant, don't need
End If
Next i
'Loop 2
'identify closing events
Dim SignalColCTC()
ReDim SignalColCTC(numRows, numOTC)
For n = 1 To numRows
If (SignalColOTC(n, 1) = "OTC_Sell") Then
list = list + 1 'scroll to next column
SignalColCTC(n, list) = "OTC_Sell" 'we know this is the sale event
For j = n + 1 To numRows 'remaining rows
'if hits mean, or makes a big loss
If ((P_Ratio(j) < Mean) Or (Abs(P_Ratio(j)) > (1 + StopLoss) * Abs(P_Ratio(n)))) Then
SignalColCTC(j, list) = "CTC_Buy" 'close position
Else
SignalColCTC(j, list) = "Wait&See"
End If
Next j
ElseIf (SignalColOTC(n, 1) = "OTC_Buy") Then 'logic repeated for sale
list = list + 1
SignalColCTC(n, list) = "OTC_Buy"
For k = n + 1 To numRows
If ((P_Ratio(k) > Mean) Or (Abs(P_Ratio(k)) < (1 - StopLoss) * Abs(P_Ratio(n)))) Then
SignalColCTC(k, list) = "CTC_Sell"
Else
SignalColCTC(k, list) = "Wait&See"
End If
Next k
End If
Next n
'Loop 3
'just filling zeros after position is closed
For o = 1 To numRows
For list = 1 To numOTC
If (SignalColCTC(o, list) = "CTC_Buy") Or (SignalColCTC(o, list) = "CTC_Sell") Then
For p = o + 1 To numRows
SignalColCTC(p, list) = "0"
Next p
End If
Next list
Next o
SignalCTC = SignalColCTC
End Function
EDIT:
Looking through the procedure, I expect the output matrix will look something like:
SignalColCTC:
OTC_Buy Null Null
Wait&See Null Null
Wait&See OTC_Sell Null
Wait&See Wait&See Null
CTC_Sell Wait&See Null
0 CTC_Buy OTC_Buy
0 0 Wait&See
(N.B. I think nulls become zeros later)
Which seems reasonable to me. Maybe what you are trying to do is transform the pairs into a single column? It seems in the image you uploaded that this is what you want.
I want this code to search the column name called((attribute value1,attribute value2..N)
If that column contains fraction values, it should convert it to decimal. I'm using this macros(VBA).
The code is working but it is converting only one column(attribute value1).
It will take more time because I have multiple columns(attribute value2...N) that have fraction values.
Please help me out I am struck here.
Sub deci()
Dim LR As Long
Dim Dash As Long
Dim Whole As Double
Dim lngDataColumn As Long
Dim pi
lngDataColumn = 4
Sheets("Sheet3").Select
LR = Cells(Rows.Count, lngDataColumn).End(xlUp).row
For r = 2 To LR
s = Cells(r, lngDataColumn)
arr = Split(s, ",")
For i = LBound(arr) To UBound(arr)
Whole = 0
P = InStr(arr(i), " IN")
If P > 0 Then
Worksheet = (Left((arr(i)), P - 1))
Else
Worksheet = arr(i)
End If
Dash = InStr(Worksheet, "-")
If Dash > 0 Then
Whole = Frac(Left(Worksheet, Dash - 1))
Worksheet = Mid(Worksheet, Dash + 1)
End If
af = Right(arr(i), Len(arr(i)) - P + 1)
evfrac = Whole + Left(CStr(Evaluate(Worksheet)), 5)
' evfrac = Whole + Format(Evaluate(frac), "0.###")
ss = ss & evfrac & af & ", "
Next i
Cells(r, lngDataColumn) = Left(ss, Len(ss) - 2)
ss = ""
Next r
End Sub
Function Frac(ByVal X As String) As Double
Dim P As Integer, N As Double, Num As Double, Den As Double
X = Trim$(X)
P = InStr(X, "/")
If P = 0 Then
N = Val(X)
Else
Den = Val(Mid$(X, P + 1))
If Den = 0 Then Err.Raise 11 ' Divide by zero
X = Trim$(Left$(X, P - 1))
P = InStr(X, " ")
If P = 0 Then
Num = Val(X)
Else
Num = Val(Mid$(X, P + 1))
N = Val(Left$(X, P - 1))
End If
End If
If Den <> 0 Then
N = N + Num / Den
End If
Frac = N
End Function
The reason it's only doing one column is because that's exactly what your telling it to do with this section of the code:
lngDataColumn = 4
Sheets("Sheet3").Select
LR = Cells(Rows.Count, lngDataColumn).End(xlUp).row
Because your setting lngDataColumn as a fixed figure, your code is only executed on column 4. If you want to do more columns as a loop, you need to increment this value in the same maner you are incrementing r in your for loop.
For example:
lngDataColumn = 10
Sheets("Sheet3").Select
For 4 To lngDataColumn
LR = Cells(Rows.Count, lngDataColumn).End(xlUp).row
'Rest of code
Next lngDataColumn