How to access an array from a certain point every loop? - vba

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

Related

Loop with multiple Ranges

Im trying to write a code which determines whether certain cells are empty or not and then returns a set string.
To go in detail; I was hoping for the code to look into cell B2, determine if it is empty, then go to C2 and determine if it is non-empty. If both were correct in cell B2 it would then input "Correct" and move on in the range. However, my code doesnt seem to work because it just inputs "Correct" in every cell in the loop range.
I have posted my code below; any help would be much appreciated.
Sub Fill_Rows()
Dim X As Range
Let Y = Range("C2")
For Each X In Range("B2:B5000")
If X = "" And Y <> "" Then
X = "Correct"
End If
Y = Y + 1
Next X
End Sub
If you meant to check by each row like (B2 and C2) then (B3 and C3), then you could do it like this.
Sub Fill_Rows()
Dim iRow As Long
For iRow = 2 To 5000
If Cells(iRow, "B").Value = vbNullString And Cells(iRow, "C").Value <> vbNullString Then
Cells(iRow, "B").Value = "Correct"
End If
Next iRow
End Sub
Alternative
Added two solutions:
[1] an example code as close as possible to yours and
[2] an alternative using a datafield array to demonstrate a faster way for bigger data sets.
[1] Example Code close to yours
There is no need to use a second variable Y, all the more as apparently you left it undeclared, which always can cause issues (type mismatches, no range object etc.).
So always use Option Explicit in the declaration head of your code module to force yourself to declare all variable types you are using.
Now you can simply use an offset of 1 column to the existing cell to check the neighbouring cell, too.
Option Explicit ' declaration head of your code module (obliges to declare variables)
Sub Fill_RowsViaRangeLoop()
Dim X As Range, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("MySheet") ' << replace with your sheet name
For Each X In ws.Range("B2:B5000")
If X = "" And X.Offset(0, 1) <> "" Then ' column offset 1 checks next cell in C
X = "Correct"
End If
Next X
End Sub
[2] Example Code using a datafield array
Looping through a bigger range isn't very fast, you can speed up your procedure by
assigning your range values to a variant datafield array v, loop through the received array items correcting found items in column 1 and write it back to sheet.
Option Explicit ' declaration head of your code module (obliges to declare variables)
Sub Fill_RowsViaArray()
Dim v As Variant, i As Long, ws As Worksheet
Set ws = ThisWorkbook.Worksheets("MySheet") ' << replace with your sheet name
' Assign values to a 2-dim array
v = ws.Range("B2:C5000") ' or better: v = ws.Range("B2:C5000").Value2
' Check criteria looping over all rows (=first array dimension)
For i = 1 To UBound(v) ' data field arrays are one-based, i.e. they start with 1
If v(i, 1) = vbNullString And v(i, 2) <> vbNullString Then v(i, 1) = "Correct"
Next i
' Write edited array back to original range (adapt the range size to the array boundaries in both dimensions)
ws.Range("B2").Resize(UBound(v, 1), UBound(v, 2)) = v
End Sub
Further Notes
It's good use to fully qualify your sheet or range references (see e.g. object variable ws)
Each array item is identified by a row and a column index.
As such a datafield array is one based (start indices are 1), the first item in row 1 and column 1 will be referred by v(1,1), in col 2 by v(1,2).
In order to count the number of row items you check the upper boundary of its first dimension) via UBound(v,1) or even shorter via Ubound(v)
In order to count the number of columns you check the upper boundary of its second dimension) via UBound(v,2) (here the argument 2 is necessary!)
A comparation using vbNullString can be preferred in coding to "" as it takes less memory (c.f. #PEH 's answer) .

Excel VBA looping: reshape column into table

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.

Sum Values based on unique ID

Just started a new job. I'm automating a month-end report and I'm new at VBA. Been googling most of my issues with success, but I've finally run into a wall. In essence I'm downloading some data from SAP and from there I need to build a report.
My question is: How to do a sumif function using loops in VBA?
Data pull:
Sheet1 contains a product code and purchase amounts (columns A & B) respectively. One product code can have several purchases (several rows with the same product code).
Steps so far:
I arranged the data sheet1 to be in ascending order.
Copied unique values for the product codes onto another sheet (sheet2). So Sheet2 has a list of all the products (in ascending order).
I want to get the sum of all purchases in sheet2 column B (per product code). I know how to do this using formulas, but I need to automate this as much as possible. (+ I'm genuinely interested in figuring this out)
This is what I did in VBA so far:
Sub Macro_test()
Dim tb As Worksheet
Dim tb2 As Worksheet
Dim x As Integer
Dim y As Integer
Dim lrow As Long
Set tb = Sheets("sheet1")
Set tb2 = Sheets("sheet2")
lrow = tb.Cells(Rows.Count, "A").End(xlUp).Row
For x = 2 To lrow
For y = 2 To lrow
If tb2.Cells(x, 1).Value = tb.Cells(y, 1).Value Then
tb2.Cells(x, 2).Value = tb.Cells(y, 2).Value
End If
Next y
Next x
End Sub
If i'm not mistaken, for each product_code in sheet2 col A, I'm looping through all the product codes in sheet1 and getting back the LAST value it finds, instead of the sum of all values... I understand why it doesn't work, I just don't know how to fix it.
Any help would be much appreciated. Thanks!
This statement overwrites the value of tb2.Cells(x, 2).Value at each iteration:
tb2.Cells(x, 2).Value = tb.Cells(y, 2).Value
Instead, I think you need to keep adding to it:
tb2.Cells(x, 2).Value = tb2.Cells(x, 2).Value + tb.Cells(y, 2).Value
But I don't like the looks of your double-loop which uses only one lrow variable to represent the "last row" on the two different worksheets, that could be causing some issues.
Or, in your loop do something like this which I think will avoid the duplicate sum. Still, assumes the second worksheet doesn't initially have any value in
' Base our lRow on Sheet2, we don't care how many rows in Sheet1.
lrow = tb2.Cells(tb2.Rows.Count, 1).End(xlUp).Row
Dim cl as Range
Set cl = tb.Cells(2,1) 'Our initial cell value / ID
For x = 2 to lRow '## Look the rows on Sheet 2
'## Check if the cell on Sheet1 == cell on Sheet2
While cl.Value = tb2.Cells(x,1).Value
'## Add cl.Value t- the tb2 cell:
tb2.Cells(x, 2).Value = tb2.Cells(x, 2).Value + cl.Offset(0,1).Value
Set cl = cl.Offset(1) '## Reassign to the next Row
Wend
Next
But it would be better to omit the double-loop and simply use VBA to do 1 of the following:
1. Insert The Formula:
(See Scott Holtzman's answer).
This approach is better for lots of reasons, not the least of which is that the WorksheetFunction is optimized already, so it should arguably perform better though on a small dataset the difference in runtime will be negligible. The other reason is that it's stupid to reinvent the wheel unless you have a very good justification for doing so, so in this case, why write your own version of code that accomplishes what the built-in SumIf already does and is specifically designed to do?
This approach is also ideal if the reference data may change, as the cell formulas will automatically recalculate based on the data in Sheet1.
2. Evaluate the formula & replace with values only:
If you prefer not to retain the formula, then a simple Value assignment can remove the formula but retain the results:
With .Range(.Range("B2"), .Range("A2").End(xlDown).Offset(, 1))
.FormulaR1C1 = "=SUMIF(Sheet1!C[-1]:C[-1],RC[-1],Sheet1!C:C)"
.Value = .Value 'This line gets rid of the formula but retains the values
End With
Use this approach if you will be removing Sheet1, as removing the referents will break the formula on Sheet2, or if you otherwise want the Sheet2 to be a "snapshot" instead of a dynamic summation.
If you really need this automated, take advantage of VBA to place the formula for you. It's very quick and easy using R1C1 notation.
Complete code (tested):
Dim tb As Worksheet
Dim tb2 As Worksheet
Set tb = Sheets("sheet1")
Set tb2 = Sheets("sheet2")
Dim lrow As Long
lrow = tb.Cells(tb.Rows.Count, 1).End(xlUp).Row
tb.Range("A2:A" & lrow).Copy tb2.Range("A2")
With tb2
.Range("A2").CurrentRegion.RemoveDuplicates 1
With .Range(.Range("B2"), .Range("A2").End(xlDown).Offset(, 1))
.FormulaR1C1 = "=SUMIF(Sheet1!C[-1]:C[-1],RC[-1],Sheet1!C:C)"
End With
End With
Note that with R1C1 notation the C and R are not referring to column or row letters . Rather they are the column and row offsets from the place where the formula is stored on the specific worksheet. In this case Sheet!C[-1] refers to the entire A column of sheet one, since the formula is entered into column B of sheet 2.
I wrote a neat little algorithm (if you can call it that) that does what you want them spits out grouped by totals into another sheet. Basically it loops through the first section to get unique names/labels and stores them into an array. Then it iterates through that array and adds up values if the current iteration matches what the current iteration of the nested loop position.
Private Sub that()
Dim this As Variant
Dim that(9, 1) As String
Dim rowC As Long
Dim colC As Long
this = ThisWorkbook.Sheets("Sheet4").UsedRange
rowC = ThisWorkbook.Sheets("Sheet4").UsedRange.Rows.Count
colC = ThisWorkbook.Sheets("Sheet4").UsedRange.Columns.Count
Dim thisname As String
Dim i As Long
Dim y As Long
Dim x As Long
For i = LBound(this, 1) To UBound(this, 1)
thisname = this(i, 1)
For x = LBound(that, 1) To UBound(that, 1)
If thisname = that(x, 0) Then
Exit For
ElseIf thisname <> that(x, 0) And that(x, 0) = vbNullString Then
that(x, 0) = thisname
Exit For
End If
Next x
Next i
For i = LBound(that, 1) To UBound(that, 1)
thisname = that(i, 0)
For j = LBound(this, 1) To UBound(this, 1)
If this(j, 1) = thisname Then
thisvalue = thisvalue + this(j, 2)
End If
Next j
that(i, 1) = thisvalue
thisvalue = 0
Next i
ThisWorkbook.Sheets("sheet5").Range(ThisWorkbook.Sheets("Sheet5").Cells(1, 1), ThisWorkbook.Sheets("Sheet5").Cells(rowC, colC)).Value2 = that
End Sub
Yay arrays

VBA Sorting of Data

The problem i run into is that sometimes entire headers and data values are missing in the dataset and therefore using the last row in the script the data is shifted up by one. For example, if i removed H11:H12 completely on sheet1 then the values for the H column associated with the data set in A11:K11 will actually be from the data set A13:K13 (or cell value H14).
The spaces shown in the second image would not be present if the respective header is not present.
Question: Given the following code; Do you think it is possible to match the data to headers and use the original offset row number alongside the column that it is matched to on sheet 2 and paste the values there? Instead the current code (and only method that worked was to find the last row).
Examples/Thoughts:
I'm thinking that the script will have to take a cell (such as D9 and recognizes it is a D and offsets to select D10 and matches that D9 record to sheet 2 column D and pastes the D10 data in D10 rather than D5.
second example, Script takes I17 and recognizes it matches I to sheet 2 column I and then offsets to select/copy and pastes the I19 data in I18 rather than I9.
Sub main()
Dim hedaerCell As Range
Dim labelsArray As Variant
With ThisWorkbook.Worksheets("Sheet2") '<--| reference "headers" worksheet
For Each hedaerCell In .Range("A1:K1") '<--| loop through all "headers"
labelsArray = GetValues(hedaerCell.Value) '<--| fill array with all labels found under current "header"
.Cells(.Rows.Count, hedaerCell.Column).End(xlUp).Offset(1).Resize(UBound(labelsArray)).Value = Application.Transpose(labelsArray)
Next
End With
End Sub
Function GetValues(header As String) As Variant
Dim f As Range
Dim firstAddress As String
Dim iFound As Long
With ThisWorkbook.Worksheets("Sheet1").UsedRange '<--| reference "data" worksheet
ReDim labelsArray(1 To WorksheetFunction.CountIf(.Cells, header)) As Variant '<--| size an array to store as many "labels" as passed 'header' occurrences
Set f = .Find(what:=header, LookIn:=xlValues, lookat:=xlWhole) '<--| start seraching for passed 'header'
If Not f Is Nothing Then
firstAddress = f.Address
Do
iFound = iFound + 1
labelsArray(iFound) = f.Offset(1)
Set f = .FindNext(f)
Loop While f.Address <> firstAddress
End If
End With
GetValues = labelsArray
End Function
Addition:
Seems like there is an exception that prevents these cell values from being copied over, if i do it manually the below screenshot would be correct. Any tips to diagnose?
Very strange because the line with the red dot copies fine in both but those four lines seem to fail.
I'm leaving my previous answer up for posterity's sake, but now that you've clarified your question I have a better answer for you.
I'm going to assume the following: 1. every two rows is a pair of headers/data; 2. the sets of row pairs may be unequal in length because if a particular header is missing for a particular row pair, there is no blank because the headers/data are shifted left; 3. there will be no blanks in the header rows until the end of the row 4. there may be blanks in the data row 5. the output should be every header (even if it only appears in 1 row) and rows of the associated data, one per header/data pair in the original sheet.
For example:
A|B|C|D|F|G|H|I <--- some headers (missing E)
1|2|3|4|6|7|8|9 <--- data row 1
A|C|D|E|G|H|I <--- some headers (missing B and F)
1|3|4|5|7|8|9 <--- data row 2
is a valid input sheet and the resulting output sheet would be:
A|B|C|D|E|F|G|H|I <--- all headers
1|2|3|4| |6|7|8|9 <--- data row 1
1| |3|4|5| |7|8|9 <--- data row 2
Use a Scripting.Dictionary of Scripting.Dictionarys to keep track of the possibly different length row pairs of headers/data. The Scripting.Dictionary of headers allows you to add new headers as they appear. The nested Scripting.Dictionarys allow you to keep track of only those rows which have a value for a particular header, but also preserve the row number for later.
As noted in the comments, the code iterates through this structure to display ALL headers and the data associated with each row. "((inputRow - 1) / 2)" calculates the output row number. You'll notice I like to iterate for loops over the count and then use offsets for indexing. I find it easier to reason about my code this way, and I find operations are easier, but you could potentially change it if you want.
Public Sub CopyDataDynamically()
Dim inputSheet As Worksheet
Dim outputSheet As Worksheet
Dim headers As Scripting.Dictionary
Set headers = New Scripting.Dictionary
Dim header As String
Dim data As String
Dim inputRow As Long
Dim inputColumn As Long
Set inputSheet = Worksheets("Sheet1")
Set outputSheet = Worksheets("Sheet2")
inputRow = 1
While Not inputSheet.Cells(inputRow, 1) = ""
inputCol = 1
While Not inputSheet.Cells(inputRow, inputCol) = ""
header = inputSheet.Cells(inputRow, inputCol).Value
data = inputSheet.Cells(inputRow + 1, inputCol).Value
If Not headers.Exists(header) Then
headers.Add header, New Scripting.Dictionary
End If
headers(header).Add ((inputRow - 1) / 2) + 1, data
inputCol = inputCol + 1
Wend
inputRow = inputRow + 2
Wend
'Output the structure to the new sheet
For c = 0 To headers.Count - 1
outputSheet.Cells(1, c + 1).Value = headers.Keys(c)
For r = 0 To ((inputRow - 1) / 2) - 1
If headers(headers.Keys(c)).Exists(r + 1) Then
outputSheet.Cells(r + 2, c + 1).Value = headers(headers.Keys(c))(r + 1)
End If
Next
Next
End Sub
I suggest, rather than copying column by column, you instead copy row by row.
Public Sub CopyData()
Dim inputRow As Long
Dim outputRow As Long
Dim inputSheet As Worksheet
Dim outputSheet As Worksheet
Set inputSheet = Worksheets("Sheet1")
Set outputSheet = Worksheets("Sheet2")
'First, copy the headers
inputSheet.Rows(1).Copy outputSheet.Rows(1)
'Next, copy the first row of data
inputSheet.Rows(2).Copy outputSheet.Rows(2)
'Loop through the rest of the sheet, copying the data row for each additional header row
inputRow = 3
outputRow = 3
While inputSheet.Cells(inputRow, 1) <> ""
inputRow = inputRow + 1 'increment to the data row
inputSheet.Rows(inputRow).Copy outputSheet.Rows(outputRow)
inputRow = inputRow + 1 'increment to the next potential header row
outputRow = outputRow + 1 'increment to the next blank output row
Wend
End Sub

Excel VBA selecting cells from filtered range

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)