I would like to visualize the marginal return of sets of data with conditional formatting, as shown in the
image. (detailed version)
I tried relative reference under R1C1, by inputing the formula:
RC - RC[-1] = 1 (or 2, 3, ..., 9)
and filling a corresponding color, but it didn't work out.
Please help and many thanks.
The code below will colour the row "combine". The code assumes that the colour palette code is between column B and K. The rest of the parameters is dynamic which you can set by yourself in the first part of the code.
It will create 2 Arrays of the Data range. Then it will compare the Arrays and write the differences in excel (Marginal Return in your example). The Marginal Return will also be stored as an Array.
Last step is to compare the Marginal Return Array with the Colour Palette Index. If the numbers match, it will copy the colour from the Palette to the Combine row for the marginal return value it should represent.
VBA Code:
Sub ColourValueDifferences()
Dim DataArray As Variant
Dim DataSubtractArray As Variant
Dim ColourArray As Variant
Dim MargRetArray() As Variant
Dim lcol As Integer
Dim fcol As Integer
Dim i As Integer
Dim j As Integer
Dim k As Integer
Dim ColourRow As Integer
Dim ColourColumn As Integer
'############### SET THE DATA PARAMETERS ###############
lcol = Cells(1, "N").Column 'Set last row
'lcol = Cells(1, Columns.Count).End(xlToLeft).Column 'Use this instead to find the last column
fcol = Cells(1, "B").Column 'Set the first column in Data Range
ColourRow = Cells(6, "B").Row 'Set which row the Colour Palette will be located. It assumes that the palette always is between column B to K
'############### CREATE THE DATA RANGES ###############
ColourArray = ThisWorkbook.Worksheets("Sheet1").Range(Cells(ColourRow, 2), Cells(ColourRow, 11)) 'Definie the range where colour scheme is
ColourArray = Application.Index(ColourArray, 1, 0) 'Make the Array 1-Dimensional
DataArray = ThisWorkbook.Worksheets("Sheet1").Range(Cells(1, fcol), Cells(1, lcol)) 'Create Array from Range to Create DataArray
DataArray = Application.Index(DataArray, 1, 0) '
DataSubtractArray = ThisWorkbook.Worksheets("Sheet1").Range(Cells(1, fcol + 1), Cells(1, lcol + 1)) '
DataSubtractArray = Application.Index(DataSubtractArray, 1, 0)
DataSubtractArray(lcol - 1) = 0 'Set last element in Array to 0
'############### CREATE THE MARGINAL RETURN VALUES ###############
For i = LBound(DataArray) To UBound(DataArray)
ReDim Preserve MargRetArray(i) 'Since we don't know the size of your final Array, we need to resize it
MargRetArray(i) = DataSubtractArray(i) - DataArray(i)
Next
MargRetArray(0) = "" 'Remove the first value
MargRetArray(i - 1) = "" 'Remove the last value
'############### PRINT THE DATA AND THE MARGINAL RETURN VALUES IN EXCEL ###############
Range(Cells(2, fcol), Cells(2, lcol)) = MargRetArray 'Print the Marginal Return
Range(Cells(1, fcol), Cells(1, lcol)).Offset(3, 0).Value = Range(Cells(1, fcol), Cells(1, lcol)).Value 'Copy Data Range To, where 3 is how many rows below the original dataset.
'############### PRINT THE DATA AND THE MARGINAL RETURN VALUES IN EXCEL ###############
For j = LBound(MargRetArray) To UBound(MargRetArray) 'Loop through the Marginal Return Array (the difference values)
ColourColumn = j + 2
For k = LBound(ColourArray) To UBound(ColourArray) 'For every index value in MargRetArray, loop through the ColourArray values
If MargRetArray(j) = ColourArray(k) Then 'If MarginalReturn value = Colour Array value, then copy the colour to the
Cells(4, ColourColumn).Interior.Color = Cells(6, k + 1).Interior.Color 'Copy colour from the palette number to the combine row
End If
Next k
Next j
End Sub
Related
I have not used VBA for sometime so am very rusty... What I have is a number of records stored vertically (in a single column) and I want to use VBA to stack them side by side (into a table).
My general thoughts about how this would flow:
Start at first range
Copy data
Paste data in cell B3 of output page (just named Sheet2)
Loop back to previous range and offset by 51 rows
Copy data
Paste data in cell C3 of output page (offset by 1 column each time)
My attempt so far:
Sub Macro1()
FiftyOne = 51 ' Offset by 51 rows for every chunk
StartRange = "L262:L303" ' Start at this range of data to copy, each chunk is identical in size
OutputRange = B3 ' Paste in output at B3, but need to offset by one column each time
Range(StartRange).Offset(FiftyOne, 0).Select
Selection.Copy
Sheets("Sheet2").Select
Range("B3").Offset(0, 1).Select
ActiveSheet.Paste
End Sub
I know this is a rather lame attempt to tackle this flow, but I am really struggling with how to loop through this. I would appreciate some advice on how to do this, or a better approach to the general flow.
Edit after accepting Wolfie's answer:
I want to assign column headings, by getting the values from C258 and looping down (in a similar way to before) 51 rows at a time, to paste into row 2 of sheet2 (B2, C2, ...).
Here is my current attempt:
Sub NameToTable()
' Assign first block to range, using easily changable parameters
' Remember to "Dim" all of your variables, using colon for line continuation
Dim blocksize As Long: blocksize = 51
Dim firstrow As Long: firstrow = 258
Dim rng As Range
Set rng = ThisWorkbook.Sheets("Sheet1").Range("C" & firstrow & blocksize - 1)
' tablestart is the upper left corner of the "pasted" table
Dim tablestart As Range: Set tablestart = ThisWorkbook.Sheets("Sheet2").Range("B2")
Dim i As Long ' Looping variable i
Dim nblocks As Long: nblocks = 10 ' We're going to loop nblocks number of times
For i = 0 To nblocks - 1
' Do the actual value copying, using Resize to set the number of rows
' and using Offset to move down the original values and along the "pasted" columns
tablestart.Offset(0, i).Resize(blocksize, 1).Value = _
rng.Offset(blocksize * i, 0).Value
Next i
End Sub
Your logic seems alright, this code will create a 51 x n table, lining up each vertical block of 51 cells in its own column.
Note, it's much quicker to assign the .Value than copying and pasting, if you need formats too then you could copy/paste or similarly set format properties equal.
Sub ColumnToTable()
' Assign first block to range, using easily changable parameters
' Remember to "Dim" all of your variables, using colon for line continuation
Dim blocksize As Long: blocksize = 51
Dim firstrow As Long: firstrow = 262
Dim rng As Range
Set rng = ThisWorkbook.Sheets("Sheet1").Range("L" & firstrow & ":L" & firstrow + blocksize - 1)
' tablestart is the upper left corner of the "pasted" table
Dim tablestart As Range: Set tablestart = ThisWorkbook.Sheets("Sheet2").Range("B3")
Dim i As Long ' Looping variable i
Dim nblocks As Long: nblocks = 10 ' We're going to loop nblocks number of times
For i = 0 To nblocks - 1
' Do the actual value copying, using Resize to set the number of rows
' and using Offset to move down the original values and along the "pasted" columns
tablestart.Offset(0, i).Resize(blocksize, 1).Value = _
rng.Offset(blocksize * i, 0).Value
Next i
End Sub
Set the nblocks value to suit your needs, this is the number of resulting columns in your output table. You could get it dynamically by knowing the number of rows in the original column. Or you could use some while logic, careful to make sure that it does eventually exit of course!
Dim i As Long: i = 0
Do While rng.Offset(blocksize*i, 0).Cells(1).Value <> ""
tablestart.Offset(0, i).Resize(blocksize, 1).Value = rng.Offset(blocksize * i, 0).Value
i = i + 1
Loop
Edit: to get your column headings, keep in mind that the column headings are only 1 cell, so:
' Change this:
Set rng = ThisWorkbook.Sheets("Sheet1").Range("C" & firstrow & blocksize - 1)
' To this:
Set rng = ThisWorkbook.Sheets("Sheet1").Range("C" & firstrow)
Tip: + is used for adding numerical values, whilst & is used for concatenating stings.
Now when you're looping, you don't need the Resize, because you are only assigning 1 cell's value to 1 other cell. Resulting sub:
Sub NameToTable()
Dim blocksize As Long: blocksize = 51
Dim firstrow As Long: firstrow = 258
Dim rng As Range
Set rng = ThisWorkbook.Sheets("Sheet1").Range("C" & firstrow)
Dim tablestart As Range: Set tablestart = ThisWorkbook.Sheets("Sheet2").Range("B2")
Dim i As Long: i = 0
Do While rng.Offset(blocksize*i, 0).Value <> ""
tablestart.Offset(0, i).Value = rng.Offset(blocksize * i, 0).Value
i = i + 1
Loop
End Sub
When dealing with your worksheets in excel, each time you reference them adds overhead and slows down the code, what you want to do is take all of the info off your spreadsheet into an array then use Application.Transpose to transpose it for you.
You can then use 'Resize' to make sure your destination range is the same size and set the values.
Sub CopyAndTransRange(src As Range, dest As Range)
Dim arr As Variant 'Needs to be a variant to take cell values
arr = Application.Transpose(src.Value) 'Set to array of values
On Error GoTo eh1dim 'Capture error from vertical 1D range
dest.Resize( _
UBound(arr, 1) - LBound(arr, 1) + 1, _
UBound(arr, 2) - LBound(arr, 2) + 1 _
) = arr 'Set destination to array
Exit Sub
eh1dim:
dest.Resize( _
1, _
UBound(arr) - LBound(arr) + 1 _
) = arr 'Set row to 1D array
End Sub
Note, Application.Transpose will fall over with some arrays in weird circumstances like if there is more than 255 characters in a string in the given array, for those situations you can write your own Transpose function to flip the array for you.
Edit:
When you feed a vertical 1-dimensional range and transpose it, VBA converts it to a 1-dimensional array, I've rewritten so it captures the error when this happens then adjusts accordingly.
Just made this example which has values 1 through 7 populated on the first 7 rows of column A. This code effectively loops through each of the values, and transposes horizontally so all values are on a single row (1).
Dim rng As Range
Dim crng As Range
Static value As Integer
Set rng = ActiveSheet.Range("A1", Range("A1").End(xlDown))
For Each crng In rng.Cells
ActiveSheet.Range("A1").Offset(0, value).value = crng.value
If value <> 0 Then
crng.value = ""
End If
value = value + 1
Next crng
First we grab the required range and then iterate through each cell. Then using the offset method and an incrementing integer, we can assign their values horizontally to a single row.
It's worth noting that this would work when trying to transpose both vertically and horizontally. The key is the offset(column, row).
Just adjust where you place your incrementing Integer.
Hope this helps.
What the case is:
So I got a "results sample" in excel format that needs filtering and reshaping to look nice. It is a result that will be not identical all the time but it follows similar rules. I have to filter it further and make it a little more tidy. I have figured out the filtering part, but I am not sure how to sort the remaining data, in a tidy way.
What the situation is:
There are six columns involved.
Notice: Real deal is not THAT simple, but what I need can be demonstrated using such a simple example and then I can manage more complex stuff myself I suppose.
For our example we use columns from B to G
The data are set as pairs of a "title" and a value.
For instance, if you look the first example picture I provide, The first detais the pair B3 and C3.
As you can see, looking at the same picture, D3 and E3 is an empty pair.
Same goes for D4 - E4 and F4 - G4 and so on until a last one at B11 - C11.
Starting data example:
[
What I want to achieve:
I would like, using Visual Basic for Applications, to sort the data, starting from let's say for our example B3 (see second picture) and fill three SETS of two columns, (BC, DE, FG) if there are no data inside those cells.
Notice: If a cell like D3 is null then SURELY E3 will be null too so there can be just only one check. I mean we can check either value columns or title columns.
Notice2: The B,D,F or C,E,G columns DON'T have to be sorted. I just want all the not-null values of B,D,F and their respective values from C,E,G gathered together neat so printing will not need 30 pages but just a few (too many spaces between is causing it and I try to automate the cleanup)
Here's something to start with. The first double loop populates a VBA Collection with Range variables that refer to the Cells that contain the titles.
The associated values are obtained by using an offset. The middle double loop performs a bubble sort on the latter (highly inefficient - you might want to replace it with something else). The next if statement creates a 2nd sheet if it doesn't exist on which to write out the results (last loop).
Option Explicit
Sub GatherData()
Dim lastRow As Integer, lastCol As Integer
Dim r As Integer, c As Integer
Dim vals As Collection
Set vals = New Collection
With Sheets(1)
lastCol = .UsedRange.Columns(.UsedRange.Columns.Count).Column
lastRow = .UsedRange.Rows(.UsedRange.Rows.Count).row
For c = 1 To lastCol Step 2
For r = 1 To lastRow
If (Trim(Cells(r, c).Value) <> "") Then
vals.Add .Cells(r, c)
End If
Next
Next
End With
' Bubble Sort
Dim i As Integer, j As Integer
Dim vTemp As Range
For i = 1 To vals.Count - 1
For j = i + 1 To vals.Count
If vals(i).Value > vals(j).Value Then
Set vTemp = vals(j)
vals.Remove j
vals.Add vTemp, vTemp, i
End If
Next j
Next i
Dim sht2 As Worksheet
If ThisWorkbook.Worksheets.Count = 1 Then
Set sht2 = ThisWorkbook.Sheets.Add(After:=ThisWorkbook.Sheets(1))
Else
Set sht2 = Worksheets(2)
End If
With sht2
r = 3
c = 2
For i = 1 To vals.Count
.Cells(r, c).Value = vals(i).Value
.Cells(r, c + 1).Value = vals(i).Offset(, 1).Value
c = c + 2
If c = 8 Then
r = r + 1
c = 2
End If
Next
End With
End Sub
Here is a method using the Dictionary object. I use early binding which requires setting a reference to Microsoft Scripting Runtime. If you are going to be distributing this, you might want to convert this to late-binding.
We assume that your data is properly formed as you show it above. In other words, all the titles are in even numbered columns; and the results are in the adjacent cell.
We create the dictionary using the Title as the Key, and the adjacent cell value for the Dictionary item.
We collect the information
Transfer the Keys to a VBA array and sort alphabetically
create a "Results Array" and populate it in order
write the results to a worksheet.
I will leave formatting and header generation to you.
By the way, there is a constant in the code for the number of Title/Value pair columns. I have set it to 3, but you can vary that.
Enjoy
Option Explicit
Option Compare Text 'If you want the sorting to be case INsensitive
'set reference to Microsoft Scripting Runtime
Sub TidyData()
'Assume Titles are in even numbered columns
'Assume want ColPairs pairs of columns for output
'Use dictionary with Title as key, and Value as the item
Dim dctTidy As Dictionary
Dim arrKeys As Variant
Dim wsSrc As Worksheet, wsRes As Worksheet, rRes As Range
Dim vSrc As Variant, vRes As Variant
Dim LastRow As Long, LastCol As Long
Dim I As Long, J As Long, K As Long, L As Long
Dim V As Variant
'in Results
Const ColPairs As Long = 3
'Set Source and results worksheet and range
Set wsSrc = Worksheets("sheet1")
Set wsRes = Worksheets("sheet2")
Set rRes = wsRes.Cells(1, 2)
'Read source data into variant array
With wsSrc.Cells
LastRow = .Find(what:="*", after:=.Item(1, 1), _
LookIn:=xlValues, searchorder:=xlByRows, searchdirection:=xlPrevious).Row
LastCol = .Find(what:="*", after:=.Item(1, 1), _
LookIn:=xlValues, searchorder:=xlByColumns, searchdirection:=xlPrevious).Column
vSrc = .Range(.Cells(1, 1), .Cells(LastRow, LastCol))
End With
'Collect the data into a dictionary
Set dctTidy = New Dictionary
For I = 1 To UBound(vSrc, 1)
For J = 2 To UBound(vSrc, 2) Step 2
If vSrc(I, J) <> "" Then _
dctTidy.Add Key:=vSrc(I, J), Item:=vSrc(I, J + 1)
Next J
Next I
'For this purpose, we can do a simple sort on the dictionary keys,
' and then create our results array in the sorted order.
arrKeys = dctTidy.Keys
Quick_Sort arrKeys, LBound(arrKeys), UBound(arrKeys)
'Create results array
ReDim vRes(1 To WorksheetFunction.RoundUp(dctTidy.Count / ColPairs, 0), 1 To ColPairs * 2)
I = 0
J = 0
For Each V In arrKeys
K = Int(I / ColPairs) + 1
L = (J Mod ColPairs) * 2 + 1
vRes(K, L) = V
vRes(K, L + 1) = dctTidy(V)
I = I + 1
J = J + 1
Next V
'write the results
Set rRes = rRes.Resize(UBound(vRes, 1), UBound(vRes, 2))
With rRes
.Worksheet.Cells.Clear
.Value = vRes
.HorizontalAlignment = xlCenter
End With
End Sub
Sub Quick_Sort(ByRef SortArray As Variant, ByVal first As Long, ByVal last As Long)
Dim Low As Long, High As Long
Dim Temp As Variant, List_Separator As Variant
Low = first
High = last
List_Separator = SortArray((first + last) / 2)
Do
Do While (SortArray(Low) < List_Separator)
Low = Low + 1
Loop
Do While (SortArray(High) > List_Separator)
High = High - 1
Loop
If (Low <= High) Then
Temp = SortArray(Low)
SortArray(Low) = SortArray(High)
SortArray(High) = Temp
Low = Low + 1
High = High - 1
End If
Loop While (Low <= High)
If (first < High) Then Quick_Sort SortArray, first, High
If (Low < last) Then Quick_Sort SortArray, Low, last
End Sub
Assuming we got all variables set and initialized properly, in this example:
Sheets("sheetname").Select ' because stupid things can happen...
For i = 3 To 13
Let newrangeT = "B" & i '
Let newrangeV = "C" & i '
If Sheets("sheetname").Range(newrangeV) <> "" Then
values(Position) = Sheets("sheetname").Range(newrangeV)
titles(Position) = Sheets("sheetname").Range(newrangeT)
Position = Position + 1
Else
' Don't do anything if the fields are null
End If
Next i
Sheets("sheetname").Range("B1:G13").Clear
' We then get each data from the arrays with a For loop.
' We set a columnset variable to 1.
' We set a currentrow variable to 3.
' If columnset is 1 data will enter in B and C and columnset = columnset +1
' Then if columnset is 2 we set data to DE and columnset = columnset +1
' But if columnset is 2we set data to FG and columnset = 1 and currentrow = currentrow +1
' Iterating the arrays will result in a neat setting of the data, but it will add zeros for all the nulls. Thus we need an If statement that will exclude that values checking the TITLE array (that should contain a title instead). if the value is not 0 then... we run what I describe, otherwise we do nothing.
Putting the data in the array is half of the trick.
Then we clear the area.
We set two string variables to declare ranges (actually cell reference) for every cell iterated in the loop. Here I demonstrated only for column set B,C
but we have to do the same for the rest of the columns.
The If statement here checks for null. You might have different needs, so changing the if statement changes the filtering. Here I check if the cells are not null. If the cells of column C contain data, put those data in values array and the respective B data on titles array but where? Position starts as 1 and we then iterate it +1 each time it adds something.
You can set data from an array using this command:
' current_row is set to the first row of the spreadsheet we wanna fill.
Sheets("sheetname").Select ' because stupid things can happen...
newrangeV = "C" & current_row
Sheets("sheetname").Range(newrangeV) = values(j)
The rest is just putting things together.
In any case, I wanna thank both of the people involved in this question, because I might didn't got the solution, but I got an idea of how to do other stuff, like accidentally learning something new. Cheers.
I've managed to connect to a web service and retrieve data to finally insert it into a sheet.
Looks like when I perform this final operation, the sheet gets the focus and the screen blinks constantly until this ends, which is a little awkward for the user and it depletes performance. We are talking that inserting about 1000 rows with 4 different parsed columns lasts for about 5 seconds.
Is there a way to do this "on the background"? I noted that basically "every action" I performed (like reading values or setting them) requests the focus on that concrete sheet, so I basically return the focus to the sheet who called the procedure once everything ended.
My code is the following:
For i = 3 To UBound(Data) - 1
If (IsNullOrWhiteSpace(Data(i))) Then
Exit Sub
End If
splitted = Split(Data(i), ";")
For j = 0 To UBound(splitted)
Cells(i - 1, j + 1).Value = splitted(j)
Next
Next
Many thanks, I'm new into this VBA world.
for starter, place:
Application.Calculation = xlCalculationManual
at the beginning of your Sub and:
Application.Calculation =xlCalculationAutomatic
right before End Sub
then let's see further three steps to speed things up:
a first step could be replacing:
For j = 0 To UBound(splitted)
Cells(i - 1, j + 1).Value = splitted(j)
Next
with:
Cells(i - 1, 1).Resize(, UBound(splitted) + 1).Value = Application.Transpose(Application.Transpose(splitted))
so that you write a whole row in one shot
a second step could be working with arrays and write the content of a 2D array in one shot:
Dim Data As Variant
Dim nRows As Long, nCols As Long, i As Long, j As Long
' >>>> here your code code to fill 'Data' variant array <<<<
ReDim notNullData(1 To UBound(Data) - 3) As Variant '<--| size 'notNullData' 1D Variant array to the maximum possible rows
For i = 3 To UBound(Data) - 1
If IsNullOrWhiteSpace(Data(i)) Then Exit For '<--| exit loop at the first null or empty 'Data' value
nRows = nRows + 1 '<--| update valid rows counter
notNullData(nRows) = Split(Data(i), ";") '<--| fill 'notNullData' array with an array from current 'Data' row content
If UBound(notNullData(nRows)) > nCols Then nCols = UBound(notNullData(nRows)) '<--| update maximum n° of columns to be written
Next
ReDim dataToWrite(1 To nRows, 1 To nCols + 1) As Variant '<--| size 'dataToWrite' 2D Variant array to 'Data' array valid rows number and calculated maximum nr of columns
'fill 2D 'dataToWrite' array processing 'notNullData' 1D array
For i = 1 To nRows
For j = 0 To UBound(notNullData(i))
dataToWrite(i, j + 1) = notNullData(i)(j)
Next
Next
'write 2D 'dataToWrite' array in one shoit
Cells(1, 1).Resize(nRows, nCols + 1).Value = dataToWrite
a third step would involve IsNullOrWhiteSpace() function
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)
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