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.
Related
I created a function that takes a range as an argument and attempts to perform a conditional LOGEST as long as the cell is not blank AND the cell does not have strike through text. However, I cannot get it to run:
Function CustomTrend(rng As Range) As Double
Dim TrendArr() As Variant
Dim ArrSpot As Integer
Dim count, countsq, countsum As Double
Dim LNy, Xsq, XxLNy As Double
Dim last As Integer
last = rng.End(xlDown).row
LNy = 0
Xsq = 0
XxLNy = 0
ArrSpot = 0
count = 0
countsq = 0
countsum = 0
For i = 1 To last Step 1
If rng.Cells(i, 1).Value <> "" And rng.Cells(i, 1).Font.Strikethrough = False Then
ArrSpot = ArrSpot + 1
count = count + 1
TrendArr(ArrSpot) = rng.Cells(i, 1).Value
End If
Next i
For k = ArrSpot To 0 Step -1
LNy = LNy + WorksheetFunction.Ln(TrendArr(ArrSpot))
XxLNy = ArrSpot * WorksheetFunction.Ln(TrendArr(ArrSpot)) + XxLNy
countsq = ArrSpot ^ 2 + countsq
countsum = countsum + ArrSpot
Next k
CustomTrend = (count * XxLNy - countsum * LNy) / (count * countsq - countsum ^ 2)
End Function
Sorted it out on my own, please see revised code below. As a note, I also had to add a .calculatefull into other parts of the code to make sure the function would update when used in a cell.
Function CustomTrend(rng As Range) As Double
Dim count, countsq, countsum As Double
Dim LNy, Xsq, XxLNy As Double
LNy = 0
Xsq = 0
XxLNy = 0
ArrSpot = 0
count = 0
countsq = 0
countsum = 0
For Each cell In rng
If cell.Value <> "" And cell.Font.Strikethrough = False Then
count = count + 1
countsum = countsum + count
LNy = LNy + WorksheetFunction.Ln(cell.Value)
XxLNy = count * WorksheetFunction.Ln(cell.Value) + XxLNy
countsq = count ^ 2 + countsq
End If
Next cell
CustomTrend = (count * XxLNy - countsum * LNy) / (count * countsq - countsum ^ 2)
End Function
I have a worksheet with over 60,000 rows and two columns. One column is transaction id, the other is item. I want to find the combinations of items in the orders. I found this vba code from someone with a similar problem
Sub basket()
On Error Resume Next
Dim ps(2, 20)
r = 3
tr = Cells(2, 1)
Item = Cells(2, 2) + "."
ps(1, 1) = 1
ps(2, 1) = Len(Item)
r2 = 2
r3 = 3
ic = 2
While Cells(r, 1) <> ""
If Cells(r, 1) <> tr Then
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
Item = ""
ic = 1
tr = Cells(r, 1)
End If
ps(1, ic) = Len(Item) + 1
ps(2, ic) = Len(Cells(r, 2)) + 1
Item = Item + Cells(r, 2) + "."
r = r + 1
ic = ic + 1
Wend
o = 1
k = 1
If ic > 1 Then
ic = ic - 1
While o = 1
For i = 1 To ic
entry = Mid(Item, ps(1, i), ps(2, i))
For j = i + k To ic
entry = entry & Mid(Item, ps(1, j), ps(2, j))
Cells(r2, 10) = tr
Cells(r2, 11) = entry
r2 = r2 + 1
x = 0
x = Application.WorksheetFunction.Match(entry, Range("e:e"), 0)
If x = 0 Then
x = r3
Cells(x, 5) = entry
r3 = r3 + 1
End If
Cells(x, 6) = Cells(x, 6) + 1
Next j
Next i
If k > Len(Item) - 1 Then o = 0
k = k + 1
Wend
End If
End Sub
Which worked when I ran the exact same code but with item categories. The problem is I'm running it with the item names and it's always crashing my Excel. Is there anyone that can guide me in the right direction?
this is the worksheet that doesn't work
this is what I get when I run it with the item category which works. They're the exact same data, one just has it as item category, and the other is item name.
Your code sample didn't do anything for me. It ran, but it didn't actually produce any kind of results at all. I did a quick Google search and found this.
Sub ListCombinations()
Dim col As New Collection
Dim c As Range, sht As Worksheet, res
Dim i As Long, arr, numCols As Long
Set sht = ActiveSheet
'lists begin in A1, B1, C1, D1
For Each c In sht.Range("A2:B2").Cells
col.Add Application.Transpose(sht.Range(c, c.End(xlDown)))
numCols = numCols + 1
Next c
res = Combine(col, "~~")
For i = 0 To UBound(res)
arr = Split(res(i), "~~")
sht.Range("H1").Offset(i, 0).Resize(1, numCols) = arr
Next i
End Sub
'create combinations from a collection of string arrays
Function Combine(col As Collection, SEP As String) As String()
Dim rv() As String
Dim pos() As Long, lengths() As Long, lbs() As Long, ubs() As Long
Dim t As Long, i As Long, n As Long, ub As Long
Dim numIn As Long, s As String, r As Long
numIn = col.Count
ReDim pos(1 To numIn)
ReDim lbs(1 To numIn)
ReDim ubs(1 To numIn)
ReDim lengths(1 To numIn)
t = 0
For i = 1 To numIn 'calculate # of combinations, and cache bounds/lengths
lbs(i) = LBound(col(i))
ubs(i) = UBound(col(i))
lengths(i) = (ubs(i) - lbs(i)) + 1
pos(i) = lbs(i)
t = IIf(t = 0, lengths(i), t * lengths(i))
Next i
ReDim rv(0 To t - 1) 'resize destination array
For n = 0 To (t - 1)
s = ""
For i = 1 To numIn
s = s & IIf(Len(s) > 0, SEP, "") & col(i)(pos(i)) 'build the string
Next i
rv(n) = s
For i = numIn To 1 Step -1
If pos(i) <> ubs(i) Then 'Not done all of this array yet...
pos(i) = pos(i) + 1 'Increment array index
For r = i + 1 To numIn 'Reset all the indexes
pos(r) = lbs(r) ' of the later arrays
Next r
Exit For
End If
Next i
Next n
Combine = rv
End Function
I found that from this link.
VBA - Write all possible combinations of 4 columns of data
I'm pretty sure if you do some more Googling, you can find other concepts that do pretty much the same thing.
I was working on a problem which requires input an array and output is also an array. I wrote the VBA code (after I had done workings of logic on notebook) but I don't know why this code is unable to fetch values of input.
I have already written the code. Just help me with the syntax!
As I am not a professional coder, please ignore the naming of variables. Also, I am new to this platform, so I am not aware of many rules. Any help will really be appreciated. Thanks!
Test cases and error:
Public Function Get1_GEM(vector As Range)
Dim i As Long, j As Long, i1 As Long, j1 As Long
Dim a As Long, b As Long, c As Long
Dim GEM() As Double
ReDim GEM(1 To 3, 1 To 2) As Double
Dim res() As Double
ReDim res(1 To 3) As Double
Dim row() As Double
ReDim row(1 To 3) As Double
For i = 1 To 3 Step 1
For j = 1 To 2 Step 1
GEM(i, j) = 2 * i + j - 2
row(i) = 0
Next j
Next i
Dim inp() As Double
ReDim inp(1 To 3) As Double
i = 0
j = 0
Dim x() As Double
ReDim x(1 To 3) As Double
Dim y() As Double
ReDim y(1 To 3) As Double
i = 0
For i = 1 To 3 Step 1
inp(i) = vector.Cells(i, 1)
Next i
For i = 1 To 3 Step 1
For j = 1 To 2 Step 1
If GEM(i, j) = inp(1) Then
x(1) = i
y(1) = j
row(i) = row(i) + 1
ElseIf GEM(i, j) = inp(2) Then
x(2) = i
y(2) = j
row(i) = row(i) + 1
ElseIf GEM(i, j) = inp(3) Then
x(3) = i
y(3) = j
row(i) = row(i) + 1
End If
Next j
Next i
i = 0
j = 0
If row(1) > 0 And row(2) > 0 And row(3) > 0 Then
For i = 1 To 3 Step 1
res(i) = GEM(x(i), 2 - y(i))
Next i
Else
If row(1) = 0 Then
a = 0
ElseIf row(2) = 0 Then
a = 1
ElseIf row(3) = 0 Then
a = 2
End If
If row(1) = 1 Then
b = 0
ElseIf row(2) = 1 Then
b = 1
ElseIf row(3) = 1 Then
b = 2
End If
c = 3 - a - b
Dim d As Double
If x(1) = b Then
d = 0
ElseIf x(2) = b Then
d = 1
ElseIf x(3) = b Then
d = 2
End If
i = 0
For i = 1 To 3 Step 1
If i = d Then
res(i) = GEM(x(i), 2 - y(i))
Else
res(i) = GEM(a, y(i))
End If
Next i
End If
Get1_GEM = res
End Function
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 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"