I run a performance database and have gotten stuck with a way to track repeat offenders.
In a Results sheet is all the data, I want to create a macro that goes through the results, filters column C to each staff number and count how many times they have a "Fail" result in column D.
If they have a count of 2 or above I want the sheet to copy their name in column B and staff no in column c to the first available line in a different sheet called "Flagged" with the fail count in a 3rd column.
My data runs from rows b8 to b10008 and I have 300 staff who could be assessed
Thanks in advance!
Set up your source data as a table (Ctrl+T with cell in range selected). Add a helper column with the formula:
=SUMPRODUCT(--([Fail/Pass]="FAIL"),--([Staff No]=[#[Staff No]]))>=2=SUMPRODUCT(--(D:D="FAIL"),--(C:C=[#[Staff No]]))>=2
Create your pivottable, Alt+N+V, using compact report layout, and add your helper column to the page field and filter on True. Add name and staff No to the row fields and remove subtotals.
As it is an Excel table you can add more rows and the formula will autofill down. You then just refresh the pivottable to update your flagged list.
Data:
Fields:
Compact design layout and no subtotals.
I would recommend to make use of arrays and loop your data that way, it should be nearly instant (comparing to looping in the sheet itself).
Keep in mind this is not fully tested, but it should get you pretty close to what you are trying to achieve:
Sub flagged()
Dim arrData As Variant, arrFails As Variant
Dim failCnt As Long, i As Long, j As Long, x As Long, lastRow As Long
Dim shResults As Worksheet, shFails As Worksheet
Set shResults = ActiveWorkbook.Sheets("Results")
Set shFlagged = ActiveWorkbook.Sheets("Flagged")
ReDim arrFails(0 To 300, 0 To 2)
arrData = shResults.Range("B8:D10008").Value
For i = LBound(arrData) To UBound(arrData)
For j = LBound(arrData) To UBound(arrData)
If arrData(i, 2) = arrData(j, 2) Then
If arrData(i, 3) = "FAIL" Then
failCnt = failCnt + 1
End If
If failCnt >= 2 Then
arrFails(x, 0) = arrData(i, 1)
arrFails(x, 1) = arrData(i, 2)
arrFails(x, 2) = failCnt
x = x + 1
End If
End If
Next j
failCnt = 0
Next i
For i = LBound(arrFails) To UBound(arrFails)
If arrFails(i, 0) <> "" Then
lastRow = shFlagged.Cells(1, j).End(xlDown).Row
For j = 1 To 3
shFlagged.Cells(lastRow + 1, j) = arrFails(i, j)
Next j
End If
Next i
End Sub
EDIT: changed the size of the dimension to accommodate 3 columns. Also I've initially done this to look for sorted data by staff number, but given is not that much data, that doesn't matter much, so I've edited out the code accordingly.
Related
I have two tables in Excel, one with categories and listings, and another with points based on the category and listing threshold. It goes as follows:
Categories table:
ID
CATEGORY
LISTINGS
Points
001
A
56
002
C
120
003
A
4
004
B
98
Points table:
Category
tier1
tier2
tier3
A
Tier 1
Tier 2
Tier 3
Range
1-30
31-90
91-
Points
10
20
30
B
Tier 1
Tier 2
Tier 3
Range
1-25
26-100
101-
Points
10
20
30
C
Tier 1
Tier 2
Tier 3
Range
1-40
41-80
81-
Points
10
20
30
I started with an INDEX MATCH formula pointing at the points:
=INDEX(Points!A1:D11, MATCH(Categories!B2, Points!A1:A11, 0)+2)
--> the +2 is to get the points directly
I also though of evaluating the thresholds with this formula:
=IF(Categories!C2 >= NUMBERVALUE(LEFT(Points!D3, FIND("-",Points!D3)-1)),Points!D4, IF(Categories!C2 >=NUMBERVALUE(LEFT(Points!C3, FIND("-",Points!C3)-1)),Points!C4, Points!B4))
I thought that the else if the if would make it faster.
Could someone help me populate the Points column in the Categories table? VBA code is also acceptable. The tables are in different sheets.
José, your original Match formula is the right starting place. It locates the particular sub-table to do a further lookup on. But in order to make this formula a whole lot simpler, can we change the ranges (1-30, 31-90, 91-) to have just their starting points (1, 31, 91)? If we do that simple change then we can use the approximate lookup feature of HLookup to easily and compactly specify the Lookup:
=HLookup($C2,Offset(Points!$A$1,Match($B2,Points!$A:$A,0),1,2,3),2,True)
In the middle of this formula you can see your original Match function to locate the correct sub-table based on the category. We need to feed that start point to OFFSET() to create a table range useful to the HLookup. Offset takes an anchor cell reference (top left of the Points table), number of rows to count down from there (result of the Match), number of columns to the right (1), the number of rows in the range (2), and the number of columns in the range (3).
The Hlookup is just like a VLookup, but for tables arranged left-to-right not top-to-bottom. The True as the last parameter is very important as it tells HLookup to use the range lookup instead of an exact match.
A slightly verbose formula which takes the data as originally formatted (using Excel 365 Let):
=LET(ranges,INDEX(Points!B$2:D$12,MATCH(B2,Points!A$1:A$12,0),0),
leftRanges,VALUE(LEFT(ranges,FIND("-",ranges)-1)),
points,INDEX(Points!B$2:D$12,MATCH(B2,Points!A$1:A$12,0)+1,0),
INDEX(points,MATCH(C2,leftRanges)))
As it's urgent this is what I got but I cannot continue before tomorrow. Assuming you can at least put the tiers next to the category (A on same line as tiers) this will get you the first tier. You just need to copy the whole formula in the "nextCol", with minor modifications to get the next tiers.
if you really cannot change the source you need to add an additional offset in the first match.
=IF(AND(D1>NUMBERVALUE(LEFT(INDIRECT("B"&MATCH(E1,A:A,0)),FIND("-",INDIRECT("B"&MATCH(E1,A:A,0)))-1)),D1<NUMBERVALUE(RIGHT(INDIRECT("B"&MATCH(E1,A:A,0)),2))),INDEX(B:D,MATCH(E1,A:A,0)+1,1),"nextCol")
Option Explicit
Sub Score()
Dim wsP As Worksheet, wsC As Worksheet, dict
Dim iLastRow As Long, r As Long, i As Long, j As Integer
Dim sCat As String, iListing As Integer
Dim data, ar
Set wsP = Sheets("Points")
Set wsC = Sheets("Categories")
Set dict = CreateObject("Scripting.Dictionary")
iLastRow = wsC.Cells(Rows.Count, 1).End(xlUp).Row
data = wsC.Range("A1:D" & iLastRow).Value2
' category to row lookup
For i = 1 To UBound(data)
If data(i, 1) = "Range" Then
dict.Add Trim(data(i - 1, 1)), i ' range
End If
Next
' scan points
iLastRow = wsP.Cells(Rows.Count, 1).End(xlUp).Row
For r = 2 To iLastRow
sCat = Trim(wsP.Cells(r, "B"))
iListing = wsP.Cells(r, "C")
If dict.exists(sCat) Then
i = dict(sCat)
For j = 4 To 2 Step -1
ar = Split(data(i, j), "-") ' lower-upper limit
If iListing >= ar(0) Then ' check lower limit
' update points
wsP.Cells(r, "D") = data(i + 1, j) ' points
Exit For
End If
Next
Else
MsgBox "No match '" & sCat & "'", vbCritical, "ERROR row " & r
End If
Next
MsgBox "done"
End Sub
Please, try the next code. It uses arrays and should be very fast, working only in memory. Please use your sheets when setting shC and shP as your real sheets. I only use the active sheet and the next one for testing reason:
Sub GetPoints()
Dim shC As Worksheet, shP As Worksheet, lastRC As Long, lastRP As Long, arrBC, arrP, arrPP, arrFin
Dim i As Long, j As Long, p As Long, k As Long
Set shC = ActiveSheet 'use here your Categories sheet
Set shP = shC.Next 'use here your Points sheet
lastRC = shC.Range("A" & shC.rows.count).End(xlUp).row
lastRP = shP.Range("A" & shP.rows.count).End(xlUp).row
arrBC = shC.Range("B2:C" & lastRC).Value 'put the range B:C in an array
arrP = shP.Range("A2:D" & lastRP).Value 'put all the range in an array
ReDim arrFin(1 To UBound(arrBC), 1 To 1) 'redim the array to keep processed values
For i = 1 To UBound(arrBC) 'iterate between Categ array elements:
For j = 1 To UBound(arrP) 'iterate between Points array elements:
If arrP(j, 1) = arrBC(i, 1) Then 'if Category is found:
For p = 2 To 4 'iterate between the next array row elements
arrPP = Split(arrP(j + 1, p), "-") 'split the element by "-" to determine the interval
If arrPP(1) <> "" Then 'for the tier3 case:
If arrBC(i, 2) >= CLng(arrPP(0)) And arrBC(i, 2) <= CLng(arrPP(1)) Then
k = k + 1
arrFin(k, 1) = arrP(j + 2, p): j = j + 2: Exit For 'place the value in the final array and exit iteration
End If
Else 'for the tier1 and tier2 cases:
If arrBC(i, 2) >= CLng(arrPP(0)) Then
k = k + 1
arrFin(k, 1) = arrP(j + 2, p): j = j + 2: Exit For 'place the value in the final array and exit iteration
End If
End If
Next p
End If
Next j
Next i
'drop the final array result at once:
shC.Range("D2").Resize(UBound(arrFin), 1).Value = arrFin
End Sub
I have the need to automatic create report that is based on the dates and portfolios.
For example if I put 2 dates and 2 portfolios like this
The report should look like this:
So if we enter 3 dates and 4 portfolios the report should have 3 tables and each one has 4 portfolios...
I'm ok to do it manual but it is ideally to be automatic,(I think it can be done through VBA, but not quite sure about it) can you guys help? Thank you.
You have to to move your data from where is stored to the Project sheet.
I guess that the date doesn't make any different on the portfolio, isn't it?
If so, it's quite easy. I don't know how your data is stored, but let's guess it's equal as shown it your screenshot.
Option Base 1 'array will start at 1 instead of 0
Public Setting As Worksheet, ListPortfolios As Worksheet, Project As Worksheet
Public RangeSelectDates As Range, RangeSelectPortfolios As Range, RowOfCodePortfolios As Range
Public ArraySelectDates(), ArraySelectPortfolios(), ArrayOfCodePortfolios(), ArrayPortfolio(), ArrayProject()
Public PortfolioCode$
Dim i%, j%, k%, r%, c%
Sub Automate()
Set Setting = Worksheets("Setting")
Set ListPortfolios = Worksheets("ListPortfolios")
Set Project = Worksheets("Project")
'First, read the portfolio code and dates to import and store in array
With Setting
Set RangeSelectDates = .Cells(4, 5).CurrentRegion
Set RangeSelectPortfolios = .Cells(4, 8).CurrentRegion
End With
ArraySelectDates = RangeSelectDates
ArraySelectPortfolios = RangeSelectPortfolios 'store the range in a Array
ReDim ArrayProject(1 To 24, 1 To 1)
'Now, create an array with the names of the portfolios where you have stored them. I don't know how your data is stored.
'I assume you've got it as the Project sheet result it's shown and also at "ListPortfolios" sheet
With ListPortfolios
Set RowOfCodePortfolios = .Rows(5)
End With
ArrayOfCodePortfolios = RowOfCodePortfolios 'store the row in a Array
k = 0 'means no value is found
For i = LBound(ArraySelectPortfolios) To UBound(ArraySelectPortfolios) 'Navigate to all the Portfolios Selected
'the portfolio codes are stored in the "second column" of the array, say PortfolioCode is the name of the portfolio
PortfolioCode = ArraySelectPortfolios(i, 2)
For j = LBound(Application.Transpose(ArrayOfCodePortfolios)) To UBound(Application.Transpose(ArrayOfCodePortfolios)) 'now navigate to where your portfolios are stored
If ArrayOfCodePortfolios(1, j) = PortfolioCode Then 'if match, create a new array with the whole portfolio
With ListPortfolios
ArrayPortfolio = .Range(.Cells(1, j), .Cells(24, j + 2)) 'I don't know the size of your data. I assume that the first column is the same of where the portfoliocode is stored and its size is 24 rows x 3 columns
End With
'now, copy it to the Project Portfolio
ReDim Preserve ArrayProject(1 To 24, 1 To 3 + k * 3)
For r = 1 To 24 'from the r (row) one to 24th. I don't know how your data is stored
For c = 1 To 3 'from the column 1 to the 3rd of each portfolio
ArrayProject(r, c + k * 3) = ArrayPortfolio(r, c) 'built the result for each portfolio found
Next c
Next r
k = k + 1 'one value is found, let's go for the next one if so
End If
Next j
Next i
If k <> 0 Then 'if any value is found then
For i = 1 To UBound(ArraySelectDates) 'let's place the date and print to the excel
ArrayProject(2, 1) = ArraySelectDates(i, 2) 'paste the date into the array
With Project
.Range(.Cells(1, 4 + 1 + (i - 1) * k), .Cells(24, UBound(Application.Transpose(ArrayProject)) + 3 + (i - 1) * k)) = ArrayProject 'print the array
'1+(i-1)*k is the first column + which date are we copying times portfolio codes found
End With
Next i
End If
End Sub
There's no error handling, either if there aren't input values may crash. But first, make it work
I am researching bird migration patterns and I am having trouble trying to figure out the best and easiest method of moving data around in excel. I am pretty good at excel, but I am terrible at macros and VBA coding, so I apologize in advance if my thinking of coding this looks completely wrong, and that there is nothing wrong with seeking expert advice. So far, I have used a pivot table to narrow out birds based on species count, location and dates.
After that, I moved the data from the dates per species and stack them from a range to a single column.
I did find a vba code that works (even though the output is actually moving the data sideways from left to right, it still is the same thing “moves B4:P4, B5:P5, B6:P6, etc..”), but this is only a single range at a time:
Sub main()
Dim i As Long
Dim cell As Range
For Each cell In Range("B4:P13")
Range("S4").Offset(i).Value = cell.Value
i = i + 1
Next cell
End Sub
My problem is that there are 56 species and 3 locations. So I would need to move the data 168 times, which is ridiculous. After I arrange them, I run a single factor analysis 56 times per species in each of the three locations. If anyone can help, that would be amazing and be very helpful for science.
My idea / hopes and dreams:
If I can repeat the code within the same VBA code module and change the values of the ranges and output locations for each species. All 3 locations have the same general format and location of the ranges (plus minus two extra dates), or if I can set the location to another sheet. Like so…
Sub main()
Dim i As Long
Dim cell As Range
For Each cell In Range("B4:P13")
Range("S4").Offset(i).Value = cell.Value
i = i + 1
For Each cell In Range("B15:P24")
Range("U4").Offset(i).Value = cell.Value
i = i + 1
For Each cell In Range("B26:P35")
Range("W4").Offset(i).Value = cell.Value
i = i + 1
For Each cell In Range("B37:P46")
Range("Y4").Offset(i).Value = cell.Value
i = i + 1
etc…
Next cell
End Sub
To look something like this:
Or more preferably this:
Again thank you for the help and contributions. :D
Bit more involved that it seemed at first glance. I've made a few assumptions so might need some tweaking if these are not tenable:
the starting workbook has only one sheet for each location, i.e. the number of sheets equals the number of locations
data starts in B4 on each sheet (and species names in A3, A14 etc)
each location sheet has the same number of species
Do use more meaningful procedure and variable names for your actual code.
Sub x()
Dim nSpec As Long, nLoc As Long, i As Long, vSpec(), j As Long, k As Long, wsOut As Worksheet, r As Range
nLoc = Worksheets.Count 'number of locations
Set r = Worksheets(1).Range("A3")
Do Until IsEmpty(r)
i = i + 1
ReDim Preserve vSpec(1 To i)
vSpec(i) = r.Value
Set r = r.Offset(11)
Loop
nSpec = UBound(vSpec) 'number of species
Set wsOut = Worksheets.Add(after:=Worksheets(Worksheets.Count)) 'add results sheet
wsOut.Name = "Results"
For i = 1 To nLoc 'headings for results sheet
With Worksheets(i) 'for each location
For j = 1 To nSpec 'for each species
wsOut.Cells(1, (j - 1) * (nLoc + 1) + 1).Value = vSpec(j) 'species heading
wsOut.Cells(2, (j - 1) * (nLoc + 1) + i).Value = .Name 'location heading
Set r = .Range("B4").Offset((j - 1) * 11).Resize(10) 'assumes B4 is top left cell of data
Do Until IsEmpty(r(1))
wsOut.Cells(Rows.Count, (j - 1) * (nLoc + 1) + i).End(xlUp)(2).Resize(10).Value = r.Value 'transfer data
k = k + 1 'move to next column
Set r = .Range("B4").Offset((j - 1) * 11, k).Resize(10)
Loop
k = 0
Next j
End With
Next i
End Sub
I have a 2 columns that look like:
field group1
a 1.2
b 0.2
c 2.4
field group2
a 0.2
c 0.8
field group3
c 0.6
d 0.8
and so forth. I have been pondering about this for a while but can't seem to find a good way.
Is there a efficient way to make the dataset look like:
field group1 group2 group3
a 1.2 0.2
b 0.2
c 2.4 0.8 0.6
d 0.8
and so forth. Any help or idea?
For a one-off, you can probably do it just with formulae to identify which groups a row is in and then pivot, as described by others in the comments to your question.
However, for repeated use / less hassle the below should work.
This works on your test data and outputs on a new sheet according to your desired output in the question.
It works in memory so it should have good performance when scaled up to thousands of cells.
Sub blah()
'Declarations
Dim outWs As Worksheet
Dim inArr, outArr
Dim vector(), groups()
Dim outC As Collection
Dim currentGroup As Long
Dim i As Long, j As Long
Dim key
'load data
inArr = Selection.Value
Set outC = New Collection
'iterate through
For i = LBound(inArr, 1) To UBound(inArr, 1)
If inArr(i, LBound(inArr, 2)) Like "field*" Then 'new group
currentGroup = currentGroup + 1
ReDim Preserve groups(1 To currentGroup)
groups(currentGroup) = inArr(i, LBound(inArr, 2) + 1) 'assign group name
Else 'is a record/field
key = inArr(i, LBound(inArr, 2))
'retrieve existing, ignoring the exception thrown if key does not exist
On Error Resume Next
vector = outC(key)
If Err.Number = 5 Then 'error raised when key does not exist
ReDim vector(0 To currentGroup)
vector(0) = key 'add key
Else
outC.Remove (key) 'the reference of item is immutable so we must remove and add again
ReDim Preserve vector(0 To currentGroup) 'resize vector
End If
On Error GoTo 0
vector(currentGroup) = inArr(i, LBound(inArr, 2) + 1) 'assign value to current group in vector
outC.Add vector, key 'add to results
Erase vector
End If
Next i
'Process our results collection into an array suitable for dumping to a sheet
ReDim outArr(1 To outC.Count, 1 To currentGroup + 1)
For i = 1 To outC.Count
For j = 0 To UBound(outC(i))
outArr(i, j + LBound(outArr, 2) - LBound(outC(i))) = outC(i)(j)
Next j
Next i
'dump data
With ActiveWorkbook.Worksheets.Add
.Range(.Cells(1, 2), .Cells(1, 1 + UBound(groups))).Value = groups
.Range(.Cells(2, 1), .Cells(1 + UBound(outArr, 1), UBound(outArr, 2))).Value = outArr
End With
Exit Sub
End Sub
I hope that helps.
so i have an idea, its not beautiful but it will probably work...
copy your whole field column and paste it to a fresh sheet, use data tab and hit remove duplicates, if you transpose that so your top row is Field, a, b, c, d you can drop a formula thats something like this (untested) "=INDEX(Sheet1!B:B, MATCH($B$1,Sheet1!A1:A3,0))"
the search range in match is intentionally small and left without $ to that if you drag this formula down it will search a little further(A2:A4,A3:A5,etc) once you get all of them just find/replace all the N/As remove blanks and your good
if i have time i will try and put together a little macro that would be a lot cleaner...
In outline: Create a copy of your group1 column, filter it for values greater than 0 and delete these. Fill the blanks with the respective groups and then pivot.
i would rearrange data first, with a macro, this way:
Sub sa()
For Each cl In Range("B2:B1000").Cells
If IsNumeric(cl.Value) And Not IsEmpty(cl.Value) Then
If Not IsNumeric(cl.Offset(-1, 0).Value) Then
cl.Offset(0, 1).Value = cl.Offset(-1, 0).Value
Else
cl.Offset(0, 1).Value = cl.Offset(-1, 1).Value
End If
End If
Next
End Sub
such that data would be rearranged with this column assignment:
[field] [value] [group]
then it would be easy to do what you want, just create a pivot table... tell me in the commentaries if in need of further help...
I want to create a list of all possible percentage splits between different number of stocks (a task required to build a proper investment opportunity set). I was able to create a macro tailored for 3 different inputs (the code is below).
Is it be possible to upgrade that macro so that it will automatically take into consideration the number of inputs (i.e. stock tickers) without the necessity to adjust the code every time? So that if input is 5 tickers instead of 3, it will create the list of all possible splits for 5 tickers?
Spreadsheet layout is simple: in row 1 I have a separate ticker in each column (3 tickers at the moment), and the split is provided below as:
ColumnA ColumnB ColumnC
row1 Ticker1 Ticker2 Ticker3
row2 0 0 100
row3 0 1 99
etc.
Here's what I'm using for 3 inputs:
Sub PercentageSplits()
Dim Lastcol As Integer
Lastcol = Sheet1.Cells(1, Columns.Count).End(xlToLeft).Column
Sheet1.Cells(1, Lastcol + 1).Value = "Total"
Sheet1.Cells(1, Lastcol + 1).Font.Bold = True
Dim row As Integer: row = 2
Dim i As Integer, j As Integer, k As Integer
For i = 0 To 100: For j = 0 To 100: For k = 0 To 100
If i + j + k = 100 Then
Sheet1.Cells(row, 1).Value = i
Sheet1.Cells(row, 2).Value = j
Sheet1.Cells(row, 3).Value = k
Sheet1.Cells(row, Lastcol + 1).Value = i + j + k
row = row + 1
End If
Next: Next: Next
End Sub
I put a quick program together to calculate these and for a total of 100 split across 5 tickers, I got more than 4.5 million results (4,598,126 to be precise). That's way too many to fit on an Excel sheet.
To make sure that the output would fit on an Excel sheet, I halved the precision by calculating combinations of 5 tickers which added to 50 and then doubling the results. This gives 316,251 results.
If you need full precision then you could adapt the code to output the data in chunks of 1 million rows per worksheet
I don't often use recursion in VBA but it seemed the obvious way to answer this particular question. I'll explain some details below the code:
Option Explicit
' We'll store each result here
Dim splitList As Collection
Sub main()
Dim splitResult As Variant
Dim splitArray As Variant
Dim splitEntry As Variant
Dim outputArray() As Variant
Dim outputRow As Long
Dim outputCol As Long
' Initial set-up
Const TOTAL_TO_SPLIT As Integer = 50
Const NO_OF_TICKERS As Integer = 5
Set splitList = New Collection
' Generate the list
findSplit TOTAL_TO_SPLIT, 1, NO_OF_TICKERS, ""
MsgBox splitList.Count
' Output the list
ReDim outputArray(1 To splitList.Count, 1 To NO_OF_TICKERS)
outputRow = 1
With Worksheets("Sheet1")
.UsedRange.Clear
For Each splitResult In splitList
outputCol = 1
If Len(splitResult) > 0 Then
splitArray = split(splitResult, ";")
For Each splitEntry In splitArray
outputArray(outputRow, outputCol) = splitEntry * 2
outputCol = outputCol + 1
Next splitEntry
End If
outputRow = outputRow + 1
Next splitResult
.Cells(2, 1).Resize(splitList.Count, NO_OF_TICKERS).Value = outputArray
End With
End Sub
' This sub is intended to be called recursively and will add an entry
' to splitList after each recursion concludes
Sub findSplit(amountToSplit As Integer, currentTicker As Integer, _
totalTickers As Integer, resultSoFar As String)
Dim i As Integer
' Call DoEvents to prevent Excel from showing as "Not Responding"
DoEvents
' Check if this is the last ticker
If (currentTicker = totalTickers) Then
splitList.Add resultSoFar & amountToSplit
Else
For i = 0 To amountToSplit
' Otherwise, generate all the possible splits by recursion
findSplit (amountToSplit - i), (currentTicker + 1), _
totalTickers, (resultSoFar & i & ";")
Next i
End If
End Sub
Notes:
this is not going to run quickly. I suggest that you bring up the Locals window (View > Locals window) in the Visual Basic editor before running the macro so you can periodically use Ctrl-Break to check on progress
you could eliminate the collection and just write directly into the 2D array but I was trying to keep the recursive part of the code as simple as possible
It's probably easiest to understand the recursive sub (findSplit) by working backwards. If we are on the final ticker (so currentTicker = totalTickers) then we only have one possibility: the amount left over after all of the previous tickers needs to be allocated to the final ticker.
If we back up a level, if we are on the second-last ticker and the amount left over is 1 then we have two choices. Allocate 0 to the second-last ticker and pass 1 on to the last ticker OR allocate 1 to the second-last ticker and pass 0 on to the last ticker. Extending things to more tickers and/or greater amounts is just a repetition of these same two rules:
if this is the last ticker, allocate whatever's left to this ticker
if this is not the last ticker, try every possible allocation of whatever was left to this ticker and pass whatever is left over on to the next ticker
Each ticker adds the amount it was allocated to a string which is added to the collection by the last ticker. An entry of 14;6;0;13;17 shows that the ticker 1 was allocated 14, ticker 2 was allocated 6 and so on. As stated above, I reduced the number of results by calculating allocations against a total of 50 and then doubled the result. So the 14;6;0;13;17 combination would output as 28;12;0;26;34 (and you'll find it in row 228559 on the output worksheet).
The code in the main sub using Split and the For Each ... Next loops converts the strings stored in the collection into a 2D array of numbers that we can drop directly on to the worksheet