I am supposed to make two market portfolios from the reversal strategy from the data given of value weighted market returns. However, I am stuck at how to proceed.
Sub REV1()
Dim c As Integer, r As Integer, g As Integer, x As Integer
Application.ScreenUpdating = False
lr = Sheets("VWMR").Cells(Rows.Count, 1).End(xlUp).Row
lc = Sheets("MRM").Cells(1, Columns.Count).End(xlToLeft).Column
Sheets.Add after:=Sheets(Sheets.Count)
Sheets(ActiveSheet.Name).Name = "REV1"
ReDim r1(lr - 2) As Variant
ReDim r2(lr - 2) As Variant
ReDim r3(lr - 2) As Variant
ReDim r4(lr - 2) As Variant
ReDim r5(lr - 2) As Variant
ReDim r6(lr - 2) As Variant
Columns("A:C").ColumnWidth = 20
For h = 1 To 2
B = 2
x = 2
For r = 2 To lr - 2 - h
Set n = Range(Sheets("VWMR").Cells(x, 2), Sheets("VWMR").Cells(x, lc))
Set m = Range(Sheets("VWMR").Cells(x + h, 2), Sheets("VWMR").Cells(x + h, lc)) _
cn = Application.WorksheetFunction.Count(n)
cm = Application.WorksheetFunction.Count(m)
If cn > 10 And cm > 10 Then
D2 = Application.WorksheetFunction.Percentile(n, 0.1)
D3 = Application.WorksheetFunction.Percentile(n, 0.9)
r2(r) = Application.WorksheetFunction.AverageIfs(m, n, "<=" & D2)
r3(r) = Application.WorksheetFunction.AverageIfs(m, n, ">=" & D3)
Sheets("REV1").Cells(B + h - 1, h + 1).Value = r2(r) - r3(r)
Sheets("REV1").Cells(B, 1).Value = Sheets("VVMR").Cells(B + 1, 1).Value
End If
B = B + 1
x = x + 1
Next
Sheets("REV1").Cells(1, h + 1).Value = "MOM" & h
Next
Sheets("REV1").Cells(1, 1).Value = "Dates"
Application.ScreenUpdating = True
Set a1 = Range(Sheets("REV1").Cells(2, 2), Sheets("REV1").Cells(lr, 2))
D = Application.WorksheetFunction.Average(a1)
MsgBox "The annual reversal returns are " & Format(Exp(D) - 1, "") & "."
End Sub
This is the code I tried to take out one portfolio first but this is not working.
Related
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 have the below code in part of my excel vba that I need to amend but could do with some help understanding.
In cells T, W, and Z there is a sum if formula in row 2, this VBA replicates this formula down to the last row. I am trying to update the formula so that it does this for column T,W,Z,AC and AF
I've changed the 1-3 to 1-5 but it is debugging at the doc(ii) line.
Please could anyone help me up understand and update it.
Dim a, k, i As Long, ii As Long, t As Long, w(1 To 3), x, dic(1 To 3) As Object
With Range("k2", Range("k" & Rows.Count).End(xlUp))
k = .Value
a = .Columns(8).Resize(, 10).Value
End With
For i = 1 To 3
Set dic(i) = CreateObject("Scripting.Dictionary")
dic(i).CompareMode = 1
ReDim x(1 To UBound(a, 1), 1 To 1) As Double: w(i) = x
Next
For i = 1 To UBound(a, 1)
For ii = 1 To 3
dic(ii)(a(i, (ii - 1) * 3 + ii + 1)) = i
Next
Next
For i = 1 To UBound(a, 1)
For ii = 1 To 3
t = (ii - 1) * 3 + ii
If dic(ii).exists(a(i, t)) Then
x = w(ii)
x(dic(ii)(a(i, t)), 1) = x(dic(ii)(a(i, t)), 1) + k(i, 1)
w(ii) = x
End If
Next
Next
For i = 1 To 3
Cells(2, (i + 4) * 4).Resize(UBound(a, 1)).Value = w(i)
Next
End Sub
I am trying parse a number string and create rows accordingly. On the left of the Example Data picture is an example of the input data with the right being my desired output. I am wanting to insert a unique row of data for each digit within the brackets for each number combination.
Here is an example of the code I used to try to solve the problem.
Option Explicit
Sub example()
Dim num As Variant
Dim x As Variant
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim m As Integer
Dim test As Variant
Dim test2 As Variant
Dim count As Integer
m = 0
For i = 1 To 3
num = Range("C" & 5 + i + m).Value
For j = 1 To Len(num)
test = Mid(num, j)
If Left(Mid(num, j), 1) = "[" Then
For k = 1 To Len(num) - (j + 1)
m = m + 1
Range("C" & 5 + m + i - 1).EntireRow.Insert
test2 = Left(Mid(num, j + k), 1)
Range("C" & 5 + m + i - 1).Value = Left(num, j - 1) + test2
Next k
End If
Next j
Next i
End Sub
Please consider using the following script:
Sub splitcombinations()
Dim rngCell As Range
Set rngCell = ThisWorkbook.Sheets(1).Range("A2")
Dim strCombinationDigits As String, strBaseDigits As String
Dim intCombinationDigitsLen As Integer
Dim x As Integer
Do While rngCell.Value2 <> ""
If InStr(rngCell.Value2, "[") > 0 Then
strCombinationDigits = Mid(rngCell.Value2, InStr(rngCell.Value2, "[") + 1, InStr(rngCell.Value2, "]") - InStr(rngCell.Value2, "[") - 1)
intCombinationDigitsLen = Len(strCombinationDigits)
strBaseDigits = Left(rngCell.Value2, InStr(rngCell.Value2, "[") - 1)
ActiveSheet.Range(rngCell.Offset(1, 0), rngCell.Offset(intCombinationDigitsLen - 1, 0)).EntireRow.Insert
For x = 1 To intCombinationDigitsLen
rngCell.Offset(x - 1, 0).Value2 = strBaseDigits & Mid(strCombinationDigits, x, 1)
rngCell.Offset(x - 1, 1).Value2 = rngCell.Offset(0, 1).Value2
rngCell.Offset(x - 1, 2).Value2 = rngCell.Offset(0, 2).Value2
Next
End If
Set rngCell = rngCell.Offset(intCombinationDigitsLen , 0)
Loop
End Sub
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
I have data which goes down a column (A:A) (see example).
The only possible values [in this case] are: 1,2,3,4,5,s,f and p,o,a,b,c, (which aren't needed in this case and can be deleted)
1-
2-
s
1
2
3
2
f
s
f
1
s
4
5
3
4
2
s
f
1
2
3
4
I need some code that will count the frequencies of numbers after certain letters have occured. In this case, i want the code to count the numbers after S or F. I have put in bold the numbers after S and in italics the numbers after F. The two numbers at the start can be ignored since no letter precedes them.
I would then need 10 different output variables
After S:
Frequency of 1:## Frequency of 2:## Frequency of 3:## Frequency of 4:## Frequency of 5:##
After F:
Frequency of 1:## Frequency of 2:## Frequency of 3:## Frequency of 4:## Frequency of 5:##
Im assuming the .countif would come in handy, have no idea to make this work though.
Is this what you are looking for? There are other ways to accomplish this as well. Let me know if you have any questions about what I did.
Private Sub CommandButton1_Click()
Dim sOne As Integer
Dim sTwo As Integer
Dim sThree As Integer
Dim sFour As Integer
Dim sFive As Integer
Dim fOne As Integer
Dim fTwo As Integer
Dim fThree As Integer
Dim fFour As Integer
Dim fFive As Integer
Dim lastRow As Integer
lastRow = ThisWorkbook.Sheets(1).Range("A1").End(xlDown).Row
For rows1 = 1 To lastRow
If ThisWorkbook.Sheets(1).Range("A" & rows1) = "s" Then
Do While WorksheetFunction.IsNumber(ThisWorkbook.Sheets(1).Range("A" & rows1 + 1))
If ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 1 Then
sOne = sOne + 1
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 2 Then
sTwo = sTwo + 1
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 3 Then
sThree = sThree + 1
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 4 Then
sFour = sFour + 1
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 5 Then
sFive = sFive + 1
End If
rows1 = rows1 + 1
Loop
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1) = "f" Then
Do While WorksheetFunction.IsNumber(ThisWorkbook.Sheets(1).Range("A" & rows1 + 1))
If ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 1 Then
fOne = fOne + 1
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 2 Then
fTwo = fTwo + 1
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 3 Then
fThree = fThree + 1
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 4 Then
fFour = fFour + 1
ElseIf ThisWorkbook.Sheets(1).Range("A" & rows1 + 1) = 5 Then
fFive = fFive + 1
End If
rows1 = rows1 + 1
Loop
End If
Next rows1
ThisWorkbook.Sheets(1).Range("H2") = sOne
ThisWorkbook.Sheets(1).Range("H3") = sTwo
ThisWorkbook.Sheets(1).Range("H4") = sThree
ThisWorkbook.Sheets(1).Range("H5") = sFour
ThisWorkbook.Sheets(1).Range("H6") = sFive
ThisWorkbook.Sheets(1).Range("J2") = fOne
ThisWorkbook.Sheets(1).Range("J3") = fTwo
ThisWorkbook.Sheets(1).Range("J4") = fThree
ThisWorkbook.Sheets(1).Range("J5") = fFour
ThisWorkbook.Sheets(1).Range("J6") = fFive
End Sub
You don't need VBA code to do this. If your values in column A only consist of the values 1,2,3,4,5,s and f then you can use a helper column as shown in the picture, below.
The formula in cell B2 is
=IF(ISNUMBER(A2),B1,A2)
and this is copied down the remaining cells of column B. After the first s or f is encountered in A, B contains either s or f dependent on which occurred in 'most recently'.
The formula for cell E4 can be seen from the picture and copying this to range E4:I5 provides your results table.
Here's a fairly flexible approach:
Sub Tester()
Dim d As Object, x As Long, k
Dim arrL, arr, L As String, c As Range, tmp
arrL = Array("s", "f")
Set d = CreateObject("scripting.dictionary")
For x = LBound(arrL) To UBound(arrL)
d.Add arrL(x), Array(0, 0, 0, 0, 0)
Next x
Set c = ActiveSheet.Range("A1")
L = ""
Do While Len(c.Value) > 0
tmp = c.Value
If d.exists(tmp) Then
L = tmp 'save the "current" letter
Else
If IsNumeric(tmp) Then
'assuming whole numbers...
If tmp >= 1 And tmp <= 5 Then
If d.exists(L) Then
'can't modify an array stored in a dictionary: copy out
arr = d(L)
arr(tmp - 1) = arr(tmp - 1) + 1
d(L) = arr 'store back in dict
End If
End If
End If
End If
Set c = c.Offset(1, 0)
Loop
'output the letters and counts
For Each k In d.keys
Debug.Print k, Join(d(k), ", ")
Next k
End Sub