The code below is part of a larger form. What I'm trying to do is:
On sheet 2 (Data List) filter data based on column 1
Based on user selected items in a listbox pull out data from the filtered range from columns 2 and 3 for specific rows and paste into sheet 1 (JHA)
I know which rows the data is in only within the filtered list because I'm storing it in a 2D array dataArr
Sheets("Data List").Select
With Worksheets("Data List").Range("A1", Sheets("Data List").Range("C1").End(xlDown))
.AutoFilter field:=1, Criteria1:=UserForm1.ListBox3.List(k) 'filter data based on user listbox selection
For j = 0 To UserForm1.ListBox1.ListCount - 1 'Find user selection from LB3 in LB1 to match filtered data order
If UserForm1.ListBox3.List(k) = UserForm1.ListBox1.List(j) Then Exit For
Next j
For h = 0 To UBound(dataArr, 2)
If dataArr(j, h) = 1 Then 'If the user has selected they want this data then add it to the array
Set myRange = Sheets("Data List").AutoFilter.Range().SpecialCells(xlCellTypeVisible)
myRange.Select
arr1(l) = myRange.Cells(h + 2, 2)
arr2(l) = myRange.Cells(h + 2, 3)
l = l + 1
End If
Next h
.AutoFilter
After this bit of code I redimension the array and paste the data on the other sheet. My issue is that myRange.cells is selecting from the unfiltered data. So for example say my filtered data set includes rows 7, 11, 15 and 21. When I filter it and set myRange it highlights 4 rows plus the header. However, when I use cells(2, 2) I get the unfiltered row 2 column 2 data, not for my filtered data set. I'm sure I'm missing something simple but I can't see what it is.
Filtered range can be (well, it almost always is!) a not contiguous one, so you have to iterate through it and pitch the nth value
You may want to use this function:
Function GetFilteredCellsNthValue(filteredRng As Range, nthVal As Long) As Variant
Dim iVal As Long, Dim cell As Range
iVal = 1
ForEach cell in filteredRng
If iVal = nthVal Then Exit For
iVal = iVal + 1
Next
GetFilteredCellsNthValue = Iif(iVal>filteredRng.Count, CVErr(xlErrValue), cell.Value)
End Function
That could be used in your "main" code as follows
arr1(l) = GetFilteredCellsNthValue( .Resize(,1).Offset(.Rows.Count - 1,1).SpecialCells(xlCellTypeVisible)), h + 2)
arr2(l) = GetFilteredCellsNthValue( .Resize(,1).Offset(.Rows.Count - 1,2).SpecialCells(xlCellTypeVisible)), h + 2)
Related
I´m new in VBA Excel. I´m trying to make a macro which is not difficult, but I´m so inexperienced.
I have sheet1 with column of dates (whole month), for each date there is different value. So column A is full of dates and column B is full of values (in relation with date). Sheet2/column A is also created by dates (whole month).
I would like to create a macro, which copy the value from sheet1/column B and pass it to sheet2/column B according to date. In other words, the macro should find certain date (in sheet2/column A) and pass specific value to sheet2/column B.
Try this, you might need to change some values to match you workbook.
Like the sheets name and starting row on the for loop.
Sub sheetValues()
'collect information in sheet one into an array
With Sheets("Sheet1")
'check last filled in cell in column / last date
Set last = .Range("A:A").Find("*", .Cells(1, 1), searchdirection:=xlPrevious)
'new array with range information
sheetOneInfo = .Range(.Cells(1, 1), .Cells(last.Row, 2)).Value
End With
With Sheets("Sheet2")
'check last filled in cell in column / last date
Set last = .Range("A:A").Find("*", .Cells(1, 1), searchdirection:=xlPrevious)
'for each cell in range
For n = 1 To last.Row
'if value in sheet two is in array
If InArray(.Cells(n, 1).Value, sheetOneInfo) > 0 Then
'put collected value in appropriate cell
.Cells(n, 2).Value = sheetOneInfo(InArray(.Cells(n, 1).Value, sheetOneInfo), 2)
End If
Next
End With
End Sub
Function InArray(val As String, arr As Variant) As Double
InArray = 0
'for each value in array
For n = 1 To UBound(arr)
'if date in array matches cell date
If arr(n, 1) = val Then
'return date position
InArray = n
Exit Function
End If
Next
End Function
You can try something like this code below. You can change numbers 100 depending how many data you have or if it changes you can calculate it.
For i = 1 To 100
For j = 1 To 100
If Sheets(2).Cells(j, 1) = Sheets(1).Cells(i, 1) Then
Sheets(2).Cells(j, 2) = Sheets(1).Cells(i, 2)
End If
Next j
Next i
I am trying to create a predictive algorithm in VBA that would search for strings in a particular row from a data source, and return a value based on the row number. This is the first step in the workflow, and in its simplest form, there are 2 tables as shown below:
Source Table:
Output Table:
This is what I'm trying to do:
Pick up the strings in Row 1 of Output Table (Blue,Black) and search for them in Rows 1,2,3,4 of Source Table.
If both strings match in a single row, the 'Input' cell from that particular row is copied to Row 1 in Output Table in the 'Output' column.
Example (2nd iteration):
From Output Table Row 2, strings Ivory,Green,Grey are picked up and queried in all rows of Source Table. If any 2 out of 3 strings match in a single row on Source Table, the Input cell of that row is copied.
In this case, Ivory and Green match in Row 1, and also in Row 4. Either input cell would work, but for the sake of having a rule, lets take the last match (Row 4). So '1,8' would be copied to Row 2 on Output Table.
This the flow I am currently using, but I'm getting an incorrect output:
For i = 2 To 5
For j = 1 To 4
For k = 2 To 5
For l = 1 To 5
If Cells(i, j).Value = Worksheets("SourceTable").Cells(k, l).Value And Cells(i,j).Value <> "" Then
For a = 1 To 5
For b = 1 To 4
If Cells(i, b).Value = Worksheets("SourceTable").Cells(k, a).Value And Cells(i, b).Value <> "" Then
Cells(i, 15).Value = Worksheets("SourceTable").Cells(k, 5).Value
GoTo iLoop
End If
Next b
Next a
End If
Next l
Next k
Next j
iLoop:
Next i
Both tables would have around half a million rows, and I am trying to figure out how to reduce the number of loops and make it work at the same time. Any suggestions would be appreciated, this would help me save a lot of man-hours and automate a major chunk of the process. Thanks!
Sub macro()
lastRowOut = Sheets("OutputTable").Range("A" & Rows.Count).End(xlUp).Row
lastRowSou = Sheets("SourceTable").Range("A" & Rows.Count).End(xlUp).Row
For i = 2 To lastRowOut
For j = 2 To lastRowSou
If checkRow(j, i) >= 2 Then
Sheets("OutputTable").Cells(i, 5) = Sheets("SourceTable").Cells(j, 6)
Exit For
End If
Next j
Next i
End Sub
Function checkRow(sRow, i)
lastCol = Split(Sheets("OutputTable").Cells(i, Columns.Count).End(xlToLeft).Address, "$")(1)
counter = 0
For Each cell In Sheets("OutputTable").Range("A" & i & ":" & lastCol & i)
If Not Sheets("SourceTable").Range("A" & sRow & ":" & "E" & sRow).Find(cell.Value) Is Nothing Then
counter = counter + 1
End If
Next cell
checkRow = counter
End Function
Quite a few things are unclear so here were the assumptions I made:
Two or more of the cells in a row in the OutputTable have to be matched for the prediction to be made.
The first rows of both the Output and Source sheet contain "Col1, Col2" etc.
You seem to not mind whether we use the first or last matching row (from the source sheet) so I went with the first.
That's 3 loops instead of 6..
you can try this
Option Explicit
Sub main()
Dim row As Range
With Worksheets("OutputTable")
For Each row In .Range("D2", .Cells(.Rows.count, 1).End(xlUp)).Rows '<--| change "D" to "OutputTable" sheet last "col" column index (i.e. the one before "Output" column)
SearchSource row
Next
End With
End Sub
Sub SearchSource(rng As Range)
Dim cell As Range, row As Range
Dim nFounds As Long
With Worksheets("SourceTable")
For Each row In .Range("E2", .Cells(.Rows.count, 1).End(xlUp)).Rows '<--| change "E" to "SourceTable" sheet last "col" column index (i.e. the one before "Input" column)
nFounds = 0
For Each cell In rng.SpecialCells(xlCellTypeConstants)
If Not row.Find(what:=cell.Value, lookat:=xlWhole, LookIn:=xlValues) Is Nothing Then nFounds = nFounds + 1
If nFounds = 2 Then Exit For
Next
If nFounds = 2 Then rng.Cells(, rng.Columns.count + 1).Value = row.Cells(, row.Columns.count + 1).Value
Next
End With
End Sub
'Try this:
'First declare some variables:
'the number of rows of the Output table
Dim OrNum as integer
'the number of columns of the Output table
Dim OcNum as integer
'the number of rows of the Source table
Dim SrNum as integer
'the number of columns of the Source table
Dim ScNum as integer
'some dummy variables for the loops
Dim rO as integer, cO as integer
Dim rS as integer, cS as integer
And then declare a boolean variable (just for later on)
Dim bool as boolean
'Then assume the output table has it's first cell at the most 'top and the most left of the output table, which is taken to 'be the cell Z1 in the following Code
'Begin with this first cell of the Output table and get each 'value in a way, that you move first (inner loop) over the 'columns by fixing the row Index (rO) of the Output table and then (outer loop) get down to each and every row like this:
For rO = 0 to OrNum - 1
For cO = 0 to OcNum - 1
Range("Z1").Offset(rO, cO)
Next
Next
'Now you don't have only strings so you will need to check, 'if the value in the cell is a string or a number. There is VBA 'function, that can help. It's called IsNumeric. It will give 'True if the value is a numeric value. If we have a string, then it will give False. With the Function IsEmpty() you can also check if a cell is empty or not. If a cell is empty, then the function IsEmpty will return True.
For rO = 0 to OrNum - 1
For cO = 0 to OcNum - 1
bool = IsNumeric(Range("Z1").Offset(rO, cO).Value)
bool = bool Or IsEmpty (Range("Z1").Offset(rO, cO).Value)
If bool=False then
'we have a string!
'do something
End if
Next
Next
I am trying to make an excel code that will compare the used range of Rows 1 and 2 of the same worksheet and delete any similar cells and move the remaining (unique values) cells to Row 1 beginning at A1.
eg) If row 1 contains these values (commas inidicate diff cells): a, b, c
and row 2 contains: a, b, c, d, e
I want the code to compare the two rows and end up with row 1 being: d, e (in columns A and B), after the code is complete. Any help would be appreciated.
Im new to VBA so im having trouble on some syntax that I would appreciate if some pros could help me out.
Get the used number of columns for rows 1 and 2 as integers. eg) maxCol1 = 3, maxCol2 = 5
Create a for loop that goes from i = 1 To maxCol2 and compares row 1 to row 2. if they are equal, make them both "", if there is something in row 2 but not in row 1, set that value to cell A1.
basically just need help on setting step 1 up.
With the help of the link posted in the comment, I figured it out! Thanks to those who helped. The code compares row 2 from row 1 and deletes any similar cell values and posts the unique values into row 1 and also into a new worksheet.
Sub CompareAndDelete()
'This code will compare the rows of each sheet and delete any old alerts that have already been emailed out
' it will then call SaveFile IF new alerts have been found
Dim row1() As Variant, row2() As Variant, newRow As Variant
Dim coll As Collection
Dim i As Long
Dim maxCol1 As Integer
Dim maxCol2 As Integer
'Find max number of columns for old and new alert
With ActiveSheet
maxCol1 = .Cells(1, .Columns.Count).End(xlToLeft).Column
maxCol2 = .Cells(2, .Columns.Count).End(xlToLeft).Column
End With
'Redimensionalize arrays
ReDim row1(0 To (maxCol1 - 1))
ReDim row2(0 To (maxCol2 - 1))
'Assign row1/row2 string values into arrays
For r = 0 To (maxCol1 - 1)
row1(r) = Cells(1, r + 1).Value
Next
For s = 0 To (maxCol2 - 1)
row2(s) = Cells(2, s + 1).Value
Next
ReDim newRow(LBound(row1) To Abs(UBound(row2) - UBound(row1)) - 1)
'Create a collection to load all row1/row2 values into
Set coll = New Collection
'Empty Collection for each run through
Set coll = Nothing
'Set collection to New before using
Set coll = New Collection
For i = LBound(row1) To (UBound(row1))
coll.Add row1(i), row1(i)
Next i
For i = LBound(row2) To (UBound(row2))
On Error Resume Next
coll.Add row2(i), row2(i)
If Err.Number <> 0 Then
coll.Remove row2(i)
End If
On Error GoTo 0
Next i
'Copy Row 2 and Paste it to Row 1
ActiveWorkbook.ActiveSheet.Rows(2).Copy
Range("A1").Select
ActiveSheet.Paste
'Now values are stored in collection, delete row 2
'Rows(2).EntireRow.ClearContents
'Paste only the new alerts onto a new worksheet that is designated for new alerts
For i = LBound(newRow) To UBound(newRow)
newRow(i) = coll(i + 1) 'Collections are 1-based
'Debug.Print newRow(i)
ActiveWorkbook.Sheets("Sheet" & index + 4).Select
ActiveWorkbook.Sheets("Sheet" & index + 4).Cells(1, i + 1).Value = newRow(i)
Next i
'if NEW alerts have been found, call SaveFile
If IsEmpty(ActiveWorkbook.Sheets("Sheet" & index + 4).Cells(1, 1)) = False Then
Call SaveFile
End If
End Sub
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
'~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
So I'm hoping for some help to automate a process that will otherwise involve copying and editing some 10,000 rows.
This is stuff relating to location data. Essentially, there are tons of these Master Rows but they do not have individual rows for Unit Numbers. I am hoping to get something to expand these into individual Unit Number rows based on what is in Column N. Column N is intended to follow a strict format of being a comma-seperated single cell list for each row.
Below is an example from Sheet 1 of what each row will have and needs to be expanded upon. Note that Column N is green and follows a consistent formatting and this will be the determinant for how many times these rows will each be expanded upon.
Below is Sheet 2 and what I want the VBA to create from Sheet 1. You can see that each row has been expanded based on the contents of Column N from Sheet 1.
Like I said, it is expected that this will involve some several thousand rows to create.
Option Explicit
Sub Tester()
Dim sht1, sht2, rwSrc As Range, rwDest As Range, v, arr, n
Set sht1 = ThisWorkbook.Sheets("Sheet1")
Set sht2 = ThisWorkbook.Sheets("Sheet2")
sht2.Range("A2:M2").Resize(3, 13).Value = sht1.Range("A2:M2").Value
Set rwDest = sht2.Range("A2:M2") 'destination start row
Set rwSrc = sht1.Range("A2:M2") 'source row
Do While Application.CountA(rwSrc) > 0
v = rwSrc.EntireRow.Cells(1, "N").Value 'list of values
If InStr(v, ",") > 0 Then
'list of values: split and count
arr = Split(v, ",")
n = UBound(arr) + 1
Else
'one or no value
arr = Array(v)
n = 1
End If
'duplicate source row as required
rwDest.Resize(n, 13).Value = rwSrc.Value
'copy over the unit values
rwDest.Cells(1, "G").Resize(n, 1).Value = Application.Transpose(arr)
'offset to next destination row
Set rwDest = rwDest.Offset(n, 0)
'next source row
Set rwSrc = rwSrc.Offset(1, 0)
Loop
End Sub
This does the work in same sheet... Pls copy the value to "Sheet2" before executing this. Not sure about efficiency though.
Public Sub Test()
Dim lr As Long ' To store the last row of the data range
Dim counter As Long
Dim Str As String ' To store the string in column N
lr = Range("N65536").End(xlUp).Row 'Getting the last row of the data
For i = lr To 2 Step -1
Str = Range("N" & i).Value ' Getting the value from Column N
counter = 1
For Each s In Split(Str, ",")
If counter > 1 Then
Range("A" & (i + counter - 1)).EntireRow.Insert ' Inserting rows for each value in column N
Range("G" & (i + counter - 1)).Formula = s ' Updating the value in Column G
Else
Range("G" & i).Formula = s ' No need to insert a new row for first value
End If
counter = counter + 1
Next s
Next i
lr = Range("G65536").End(xlUp).Row
' Pulling down other values from the first value row other rows
Range("A1:N" & lr).Select
Selection.SpecialCells(xlCellTypeBlanks).Select
Selection.FormulaR1C1 = "=R[-1]C"
' Pasting the data as Values to avoid future formula issues.
Range("A1:N" & lr).Copy
Range("A1:N" & lr).PasteSpecial xlPasteValues
MsgBox "Done"
End Sub
Question detail
My code below stores the results from a calculation in array funds() and repeats that process for the selected range. By the end there will be a one dimensional array with 170 values. I need to access the array from a certain point every loop to fill the new row with different values.
Problem in detail
The core problem I am having is printing that array to a range on the workbook which is made up of 10 rows by 17 columns.
I managed to get it to go down a row once the "for each cell in selected range" loop exits, but now it fills the new row with the same initial array values!
Here is the current output:
What have i tried?
I have tried the Redim but get overwhelmed by the length of examples.
I have tried manual copy and paste but feel like that is cheating...
I have researched how to delete elements through the process of copying..
Overall I am sure there is a simple way that everyone knows how to use! but what is it?
In a nutshell...
Every loop remove the initial 17 values, then print the next 17 array values to new row in range. Repeat 10 times.
The code
Option Explicit
Public funds(0 To 170) As Variant
Sub cumulativeperformance()
Dim selectedrange As Range
Dim cell As Range
Dim value1 As Double
Dim Value2 As Long
Dim i, x, d, c As Integer
Dim total(0 To 170) As Double
'Copy the table to report
Worksheets("Data").Range("C3:T13").Copy
Sheets("Report").Range("B39").PasteSpecial
Worksheets("Data").Range("B3:T13").Copy
Sheets("Report").Range("A39").PasteSpecial xlPasteValues
'Repeat 9 times
c = 39
For d = 0 To 9
c = c + 1
Set selectedrange = Worksheets("Report").Range(Cells(c, 3), Cells(c, 19))
For Each cell In selectedrange
value1 = cell.Value
'get the value of cell to the left of current cell
Value2 = cell.Offset(0, -1).Value
'get the difference to previous month
value1 = value1 / Value2 - 1
'assign result + 1 to array
total(x) = value1 + 1
'If initial fund slot is 0, then store first result of calculation in that slot
If i = 0 Then
funds(i) = total(0) - 1
ElseIf i > 0 Then
'Do calculation on remaining values and store in fund array
funds(i) = (funds(i - 1) + 1) * total(i) - 1
End If
'MsgBox "cumulative performance: " & funds(I) & " Cell address: " & cell.Address
i = i + 1
x = x + 1
Next
'Write from one dimensional Array To The worksheet
Dim Destination As Range
Dim j As Integer
Set Destination = Range(Cells(c, 3), Cells(c, 3)) 'starts at
Set Destination = Destination.Resize(1, 17) 'UBound(funds))
Destination.Value = funds
'MsgBox "Hi there"
Next d
'one-off commands in here
Range("C40:S49").NumberFormat = "0.00%"
Call portfoliomay
End Sub
The destination range and the source array should have the same dimensions to be able to assign the values correctly, as commented by Ron Rosenfeld. This is possible by either using a 1-dimension array to reuse 10 times for just one row at a time array(columns), or a 2-dimensions array for the full destination range (10x17) array(rows, columns).
Method #1: 1-dimension array
Use a 1-dimension array of 17 values, for a row by row operation, one row at a time. Initially declare the array as a dynamic array Dim funds() ..., so you'll be able to easily reset it. Then set its zero based length ReDim funds(16) ... at the beginning of each For d = 0 To 9 iteration. The rest of your code will stay the same. With this method your original destination assignment should work as expected Destination.Value = funds (or with an equivalent shorter statement Cells(c, 3).Resize(1, 17) = funds).
Method #2: 2-dimensions array
You can declare funds as a zero based 2-dimensions array Dim funds(9, 16) .... But then there is no straight forward way to put the data in row by row. The destination assignment will be to the whole range at once Cells(40, 3).Resize(10, 17) = funds after your calculation loops end. You will also need to adjust the funds directives to indicate the row funds(d, i) = .... This may be the most efficient way (performance wise) to put in the data in your sheet, as putting data in cells is relatively time consuming.
*To do it row by row with a 2-dimensions array you'll have to use a workaround like the ones described here return an entire row of a multidimensional array in VBA to a one dimensional array.
Other adjustments
You will need to adjust your total array to have the same dimensions and directives as the funds, or adjust i and x calculations. To adjust i and x and leave total as is, add i = 0 at the beginning of your For d iteration, and use only total(x).
edited after OP's confirmation his goal is optimizing code (see at the end)
I'm adding a different "flavor" of array/ranges use and showing some possible code enhancements
Variant variable as array
there's no need to Dim or Redim any array, just declare ita as a pure Variant variable and fill it with the range values that will host the final results
some thing like
funds = repRng.Value
where repRng is the Range of the "Report" sheet that you want to fill with funds array itself
reduce variables
there's no need for a total array at all. just use a simple Double variable
Dim appropriately
Dim i, x, d, c As Integer
would result in declaring i, x and d variables as of Variant type and only c as of Integer type
to have all those variables declared as integer you must type:
Dim i As Integer, x As Integer, d As Integer, c As Integer
but we'll use much less of them
reduce code
since you're assigning
value1 = value1 / Value2 - 1
and then
total(x) = value1 + 1
you could merge those two statements into the single
total(x) = value1 / Value2
which, for what above said, we'll change to:
total = value1 / Value2
copy/paste
these statements:
Worksheets("Data").Range("C3:T13").Copy
Sheets("Report").Range("B39").PasteSpecial
Worksheets("Data").Range("B3:T13").Copy
Sheets("Report").Range("A39").PasteSpecial xlPasteValues
actually do the same as:
Worksheets("Data").Range("B3:T13").Copy
Sheets("Report").Range("A39").PasteSpecial xlPasteValues
which can also be written as:
With Worksheets("Data").Range("B3:T13")
Sheets("Report").Range("A39").Resize(.Rows.Count, .Columns.Count).Value = .Value
End With
this approach both reduces time (not an issue for such little a range) and doesn't use the clipboard (which at least you'd take care releasing with Application.CutCopyMode = False)
for what above said, this statement will be used to initialize repRng Range variable, too
With Worksheets("Data").Range("B3:T13")
Set repRng = Sheets("Report").Range("A39").Resize(.Rows.Count, .Columns.Count) '<--| define the range where to paste data
repRng.Value = .Value '<--| paste data
End With
Reduce variables (part2)
your d variable is used only for iterating through rows you just previously copied and pasted, but you're using hard coded values for its span and then making it relative to another hard coded reference row index (c = 39)
you'd better exploit consistente reference to the range you're actually dealing with, like (pseudo code)
Dim oneRow As Range
For Each oneRow In repRng.Rows '<--| loop through rows of your relevant data range
For Each cell In oneRow.Cells '<--| loop through cells of the current data range row
'code
Next cell
Next row
where repRng is a Range object referencing relevant cells of sheet "Report" you want to loop through
The final outcome will be the following code:
Option Explicit
Public funds As Variant '<--| declare the simple Variant variable that will be "turned" into an array as long as we'll initialize it to a "Range" values
Sub cumulativeperformance()
Dim cell As Range, repRng As Range, oneRow As Range
Dim value1 As Double, total As Double
Dim value2 As Long
Dim iRow As Long, jCol As Long '<--| better use "Long" instead of "Integer" when dealing with numbers that cope with Excel rows indexs
'Copy table values to report
With Worksheets("Data").Range("B3:T13")
Set repRng = Sheets("Report").Range("A39").Resize(.Rows.Count, .Columns.Count) '<--| define the range where to paste data
repRng.Value = .Value '<--| paste data
End With
With repRng
Set repRng = .Offset(1, 2).Resize(.Rows.Count - 1, .Columns.Count - 2) '<--| redefine the relevant data range to loop through
End With
With repRng '<--| assume your relevant data range as reference
funds = .Value '<--| have funds array properly dimensioned by filling it with relevant data pasted values: they'll be rewritten in following loops
For Each oneRow In .Rows '<--| loop through rows of your relevant data range
iRow = iRow + 1 '<--| update array row counter
jCol = 1 '<--|for each new row restart array column counter
For Each cell In oneRow.Cells '<--| loop through cells of the current data range row
value1 = cell.Value '<--|get the value of current cell
value2 = cell.Offset(0, -1).Value '<--|get the value of cell to the left of current cell
total = value1 / value2 '<--|evaluate the ratio
If jCol = 1 Then
funds(iRow, jCol) = total - 1 '<--| If initial fund slot is 1, then store first result of calculation in that slot
Else
funds(iRow, jCol) = (funds(iRow, jCol - 1) + 1) * total - 1 '<--| Do calculation on remaining values and store in fundS array
End If
jCol = jCol + 1 'update array column counter
Next cell
Next oneRow
.Value = funds '<--| fill your relevant data range with funds values
.NumberFormat = "0.00%"
End With
' Call portfoliomay
End Sub
further optimization would avoid the If jCol = 1 Then check for every row, since it's not up to some unknown condition: we know for sure that every new row will start with a column index 1
so, for every row, we can
act on its initial column:
funds(iRow, 1) = GetTotal(oneRow.Cells(1, 1)) - 1 'evaluate funds current row first slot (column)
relying on a specific GetTotal() function
Function GetTotal(cell As Range) As Double
Dim value1 As Double
Dim value2 As Long
value1 = cell.Value '<--|get the value of current cell
value2 = cell.Offset(0, -1).Value '<--|get the value of cell to the left of current cell
GetTotal = value1 / value2 '<--|evaluate the ratio
End Function
where we collected the code to calculate total value "attached" to a single cell
do calculation for subsequent columns
jCol = 2 '<--|for each new row restart array column counter
For Each cell In Range(oneRow.Cells(1, 2), oneRow.Cells(1, oneRow.Cells.Count)) '<--| evaluate funds current row remaining slots
funds(iRow, jCol) = (funds(iRow, jCol - 1) + 1) * GetTotal(cell) - 1
jCol = jCol + 1 'update array column counter
Next cell
exploiting the same GetTotal() function
Finally the updated code would be:
Option Explicit
Public funds As Variant '<--| declare the simple Variant variable that will be "turned" into an array as long as we'll initialize it to a "Range" values
Sub cumulativeperformance()
Dim cell As Range, repRng As Range, oneRow As Range
Dim iRow As Long, jCol As Long '<--| better use "Long" instead of "Integer" when dealing with numbers that cope with Excel rows indexs
'Copy table values to report
With Worksheets("Data").Range("B3:T13")
Set repRng = Sheets("Report").Range("A39").Resize(.Rows.Count, .Columns.Count) '<--| define the range where to paste data
repRng.Value = .Value '<--| paste data
End With
With repRng
Set repRng = .Offset(1, 2).Resize(.Rows.Count - 1, .Columns.Count - 2) '<--| redefine the relevant data range to loop through
End With
With repRng '<--| assume your relevant data range as reference
funds = .Value '<--| have funds array properly dimensioned by filling it with relevant data pasted values: they'll be rewritten in following loops
For Each oneRow In .Rows '<--| loop through rows of your relevant data range
iRow = iRow + 1 '<--| update array row counter
funds(iRow, 1) = GetTotal(oneRow.Cells(1, 1)) - 1 'evaluate funds current row first slot (column)
jCol = 2 '<--|for each new row restart array column counter
For Each cell In Range(oneRow.Cells(1, 2), oneRow.Cells(1, oneRow.Cells.Count)) '<--| evaluate funds current row remaining slots
funds(iRow, jCol) = (funds(iRow, jCol - 1) + 1) * GetTotal(cell) - 1
jCol = jCol + 1 'update array column counter
Next cell
Next oneRow
.Value = funds '<--| fill your relevant data range with funds values
.NumberFormat = "0.00%"
End With
' Call portfoliomay
End Sub
Function GetTotal(cell As Range) As Double
Dim value1 As Double
Dim value2 As Long
value1 = cell.Value '<--|get the value of current cell
value2 = cell.Offset(0, -1).Value '<--|get the value of cell to the left of current cell
GetTotal = value1 / value2 '<--|evaluate the ratio
End Function
some final(?) notes:
A. Public variables
these are used to share variables among different subs/function across different modules
but it's usually a bad practice using them, being preferable put those variables in subs/function parameters to carry them along where needed
with the code as in the question, there is no other sub/function using funds, so it better move its declaration into cumulativeperformance():
Option Explicit
Sub cumulativeperformance()
Dim funds As Variant '<--| declare the simple Variant variable that will be "turned" into an array as long as we'll initialize it to a "Range" values
Dim cell As Range, repRng As Range, oneRow As Range
B. simplify GetTotal()
it can be simplified to
Function GetTotal(cell As Range) As Double
With cell
GetTotal = .Value / .Offset(0, -1).Value '<--|evaluate the ratio
End With
End Function
taking advantage of the `With cell` statement and referring to it