need to create a list in excel for all possible combinations (unique): Let say there are 5 buttons (e.g A B C D E) and 3 are selected. For any single combination, any selected button can't be repeated in that combination.
I should get 60 unique combinations ( 5 1 ) * ( 4 1 ) * ( 3 1 ) = 60. I need to create this list in excel.
e.g have A B C D E buttons. 3 buttons combinations: A B C; C B A; D A C; C D A; A D C; etc.
By "unique" I assume that you want to exclude things like AAD or ABB.
Consider:
Option Explicit
Sub Kombos()
Dim arr(1 To 5) As String
Dim brr(1 To 5) As String
Dim i As Long, j As Long, k As Long
Dim N As Long, V As String
arr(1) = "A"
arr(2) = "B"
arr(3) = "C"
arr(4) = "D"
arr(5) = "E"
N = 1
For i = 1 To 3
For j = i + 1 To 4
For k = j + 1 To 5
Cells(1, N) = arr(i) & arr(j) & arr(k)
N = N + 1
Next k
Next j
Next i
'''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''''
For i = 1 To 10
V = Cells(1, i).Value
brr(1) = Left(V, 1)
brr(2) = Mid(V, 2, 1)
brr(3) = Right(V, 1)
Cells(2, i) = brr(1) & brr(3) & brr(2)
Cells(3, i) = brr(2) & brr(1) & brr(3)
Cells(4, i) = brr(2) & brr(3) & brr(1)
Cells(5, i) = brr(3) & brr(1) & brr(2)
Cells(6, i) = brr(3) & brr(2) & brr(1)
Next i
End Sub
Each column is a different combination of 5 elements taken 3 at a time. (10 columns)
The rows below the first row list the various permutations of the column header.
Related
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.
i have problem with my code in vba. I have to find how much similar numbers are in column 1 and 2, but for example Column 1 (6,6,34,21,23,40) and column2 (49,34,6,9,6,20) should write 3 cause there are pairs 6-6, 6-6 and 34-34. I know its messy explenation but i hope its understandable. My code so far is:
Sub totolotek()
Dim i As Integer
Dim x As Integer
Dim j As Integer
Dim liczba As Integer
Dim suma As Integer
Dim ileLosowan As Integer
Range("B2:C7").Interior.Color = RGB(135, 134, 125)
Range("B2:B7").Font.ColorIndex = 3
Range("C2:C7").Font.ColorIndex = 5
ileLosowan = 7
Randomize
For i = 2 To ileLosowan
x = Int(Rnd * (49) + 1)
Range("c" & i) = x
Next i
For i = 2 To 7
liczba = Range("c" & i)
For j = 2 To 7
liczbe = Range("b" & j)
If liczbe = liczba Then
Range("c" & i).Interior.Color = RGB(255, 255, 0)
Range("b" & j).Interior.Color = RGB(255, 255, 0)
suma = suma + 1
End If
Next j
Next i
Range("c" & 9) = suma
End Sub
Try this. I invested some time and I added some lines of code. The macro find all the number pairs.
Example (6,6,3,4,2) (2,3,6,9,0) --> results 3: (6-6, 3-3, 2-2)
Sub totolotek()
Dim i As Integer
Dim x As Integer
Dim j As Integer
Dim liczba As Integer
Dim suma As Integer
Dim ileLosowan As Integer
Dim str_B As String, str_C As String, str_BC As String
Dim max_rand As Long
ileLosowan = 20 ' you can change the number of element in the column
max_rand = 49 ' max randum number
start_row = 2 'start_row
str_BC = "B2:C" & ileLosowan
str_B = "B2:B" & ileLosowan
str_C = "C2:C" & ileLosowan
Range(str_BC).Interior.Color = RGB(135, 134, 125)
Range(str_B).Font.ColorIndex = 5
Range(str_C).Font.ColorIndex = 5
Randomize
For i = start_row To ileLosowan
x = Int(Rnd * (max_rand) + 1)
Range("C" & i) = x
Next i
For i = start_row To ileLosowan
x = Int(Rnd * (max_rand) + 1)
Range("B" & i) = x
Next i
liczba_array = Range("B" & start_row & ":B" & ileLosowan).Value2
liczbe_array = Range("C" & start_row & ":C" & ileLosowan).Value2
ReDim ID_array(1 To 1)
ID_array(1) = max_rand + 1
Count = 1
For i = 1 To UBound(liczba_array, 1)
For j = 1 To UBound(liczbe_array, 1)
For k = 1 To UBound(ID_array, 1)
If ID_array(k) = j Then
GoTo out
End If
Next k
If liczba_array(i, 1) = liczbe_array(j, 1) Then
Range("B" & (start_row + i - 1)).Interior.Color = RGB(150 + Count * 20, 0, 0)
Range("C" & (start_row + j - 1)).Interior.Color = RGB(150 + Count * 20, 0, 0)
suma = suma + 1
ID_array(Count) = j
Count = Count + 1
ReDim Preserve ID_array(1 To Count)
Exit For
End If
Next j
out:
Next i
Range("C" & ileLosowan + 2) = suma
End Sub
Something like this will do what you're after. Just incorporate it into you're code cause I don't really know what's going on there.
Dim i As Long, j As Long, arr As Variant, Total As Integer
For i = 2 To 7 'Rows to loop through in the column
Total = 0
arr = Split(Range("A" & i), ",") 'Split column A using the comma
For j = 0 To UBound(arr) 'Loop through the split values
If InStr(Range("B" & i), arr(j)) > 0 Then 'Find if value is within other column
Total = Total + 1 'If it is, add 1 to total
End If
Next j
Range("C" & i) = Total 'Write total to another column on same row
Next i
Or if you want a basic function for it that you can use in your sheet you can use this:
Public Function CountMatches(Cell As String, Rng As Range, Optional Delim As String)
Dim i As Long, j As Long, arr As Variant, Total As Integer
If Delim = "" Then Delim = ","
If Rng.Count > 1 Then
CountMatches = "Please choose 1 cell to compare to."
Exit Function
End If
Total = 0
arr = Split(Cell, Delim) 'Split column A using the comma
For j = 0 To UBound(arr) 'Loop through the split values
If InStr(Rng, arr(j)) > 0 Then 'Find if value is within other column
Total = Total + 1 'If it is, add 1 to total
End If
Next j
CountMatches = Total
End Function
Use it like =CountMatches(A1,B1,",")
Well I have the following problem, I have 2 columns as follows:
A B
"X" 1
"Y" 1
"Z" 0
"W" 2
What I want to do is find a way to create new columns C and D or better still, update columns A and B as follows:
C D
"X" 1
"Y" 1
"Z" 0
"W (1)" 1
"W (2)" 1
Any suggestion or ideas on how can i do this will be much appreciated.
This is not supposed to be a code writing forum. You are expected to show some effort.
Sub split_()
Dim P1 As Range
Range("C1:D99999").Clear
Set P1 = Range("A1").CurrentRegion
a = 1
For i = P1(1).Row To P1.Rows.Count
If P1(i, 2) > 1 Then
For j = 1 To P1(i, 2)
Cells(a, 3) = P1(i, 1) & " (" & j & ")"
Cells(a, 4) = 1
a = a + 1
Next j
Else
Cells(a, 3) = P1(i, 1)
Cells(a, 4) = P1(i, 2)
a = a + 1
End If
Next i
End Sub
I need to track a person in a data sheet to determine from which location to which location the person moved.
If a person appears more then one time in Column J that means the person has changed the location and the location value is in Column L. For this I have the following code:
=IF(J18=J19;IF(COUNTIF(J:J;J18)>1; "From "&L18 &" to "& IF(J18=J19;L19;"");"");"")
The problem is if the person changes the location more than two times. In Column O to Column AA I have the months of the year which determines the location of the person.
How can I modify this code to do the above:
=IF(J18=J19;IF(COUNTIF(J:J;J18)>1; "From "&L18 &" to "& IF(J18=J19;L19;"");"");"")
Here is a User Defined Function (aka UDF) to accomplish the task.
Function my_Travels(nm As Range, loc As Range, cal As Range)
Dim n As Long, cnt As Long, v As Long, vLOCs As Variant, vTMPs As Variant
Dim iLOC As Long, sTMP As String
my_Travels = vbNullString '"no travels"
cnt = Application.CountIf(nm.EntireColumn, nm(1))
If Application.CountIf(nm, nm(1)) = cnt And cnt > 1 Then
Set loc = loc.Rows(1).Resize(nm.Rows.Count, loc.Columns.Count)
Set cal = cal.Rows(1).Resize(nm.Rows.Count, cal.Columns.Count)
'seed the array
ReDim vLOCs(1 To cnt, 1 To cnt)
For v = LBound(vLOCs, 1) To UBound(vLOCs, 1)
vLOCs(v, 1) = cal.Columns.Count + 1
vLOCs(v, 2) = cal.Columns.Count + 1
Next v
'collect the values into the array
For n = 1 To nm.Rows.Count
If nm.Cells(n, 1).Value2 = nm.Cells(1, 1).Value2 Then
iLOC = Application.Match(1, Application.Index(cal, n, 0), 0)
For v = LBound(vLOCs, 1) To UBound(vLOCs, 1)
If vLOCs(v, 1) = cal.Columns.Count + 1 Then
vLOCs(v, 1) = iLOC
vLOCs(v, 2) = n
Exit For
End If
Next v
End If
Next n
'sort the values in the array
For v = LBound(vLOCs, 1) To (UBound(vLOCs, 1) - 1)
For n = (v + 1) To UBound(vLOCs, 1)
If vLOCs(v, 1) > vLOCs(n, 1) Then
vTMPs = Array(vLOCs(v, 1), vLOCs(v, 2))
vLOCs(v, 1) = vLOCs(n, 1)
vLOCs(v, 2) = vLOCs(n, 2)
vLOCs(n, 1) = vTMPs(0)
vLOCs(n, 2) = vTMPs(1)
Exit For
End If
Next n
Next v
'concatenate the locations from the array
For v = LBound(vLOCs) To (UBound(vLOCs) - 1)
sTMP = sTMP & "From " & loc.Cells(vLOCs(v, 2), 1) & " to " & loc.Cells(vLOCs(v + 1, 2), 1) & "; "
Next v
'truncate the string and return it
sTMP = Left(sTMP, Len(sTMP) - 2)
my_Travels = sTMP
End If
End Function
The Locations and the Calendar cells only need to be defined by the first row. Each has its height (i.e. rows) redefined to maintain consistency with the list of names.
In AB2 (as above) the formula is,
=my_Travels(J2:J$8, L2, O2:AA2)
Fill down as necessary.
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