How do I sum across rows in a macro? SumIf?

[future]

I am having trouble writing a code that performs a sum if calculation
on a dynamic range of cells. For each "item" I want 1 row that sums
the totals for each date. See below:


I currently have this data on Sheet 1.

11.01 11.02 11.03 11.04 11.05
1 4 5 6 7 8
1 9 10 11 12 13
1 14 15 16 17 18
2 19 20 21 22 23
2 24 25 26 27 28
2 29 30 31 32 33
3 34 35 36 37 38
3 39 40 41 42 23
3 44 45 46 47 48

I built a macro to get this on Sheet 2.

11.01 11.02 11.03 11.04 11.05
1
2
3

Ultimately I want this on Sheet 2.

11.01 11.02 11.03 11.04 11.05
1 27 20 33 36 39
2 72 75 57 81 84
3 117 120 123 126 109


What is the best way to populate this matrix. The number of dates and
"items" will change.

This is what I current have, but I can't figure out how to sum across
rows to populate sheet 2.

Any ideas?

Sub Unique2()
Dim cLastRow As Long
Dim i As Long
Dim j As Long
Dim thisValue As Long
Dim isUnique As Boolean
Dim outputRow As Long

outputRow = 1

cLastRow = Cells(Rows.Count, "A").End(xlUp).Row


For i = 1 To cLastRow

thisValue = Cells(i, 1)
isUnique = True

If Not i = cLastRow Then

For j = i + 1 To cLastRow

If thisValue = Cells(j, 1) Then isUnique = False

Next j

End If



If isUnique Then

'output somewhere
Sheet2.Cells(outputRow, 1) = thisValue
outputRow = outputRow + 1


End If
Next i
End Sub


Sub CopyDateRange()

Rows("1:1").Select
Selection.Copy
Sheets("Sheet2").Select
Rows("1:1").Select
ActiveSheet.Paste
End Sub

 

[Guest]

Hi

In your output have the macro put in the SUMIF formula (or SUMPRODUCT) and reference the formula to the source data. If you don't want the formula to remain in the output, then copy the results and then value paste. You only have to build the formula into one cell, then you can copy / paste or use fill.


Tony

----- future wrote: -----

I am having trouble writing a code that performs a sum if calculation
on a dynamic range of cells. For each "item" I want 1 row that sums
the totals for each date. See below:


I currently have this data on Sheet 1.

11.01 11.02 11.03 11.04 11.05
1 4 5 6 7 8
1 9 10 11 12 13
1 14 15 16 17 18
2 19 20 21 22 23
2 24 25 26 27 28
2 29 30 31 32 33
3 34 35 36 37 38
3 39 40 41 42 23
3 44 45 46 47 48

I built a macro to get this on Sheet 2.

11.01 11.02 11.03 11.04 11.05
1
2
3

Ultimately I want this on Sheet 2.

11.01 11.02 11.03 11.04 11.05
1 27 20 33 36 39
2 72 75 57 81 84
3 117 120 123 126 109


What is the best way to populate this matrix. The number of dates and
"items" will change.

This is what I current have, but I can't figure out how to sum across
rows to populate sheet 2.

Any ideas?

Sub Unique2()
Dim cLastRow As Long
Dim i As Long
Dim j As Long
Dim thisValue As Long
Dim isUnique As Boolean
Dim outputRow As Long

outputRow = 1

cLastRow = Cells(Rows.Count, "A").End(xlUp).Row


For i = 1 To cLastRow

thisValue = Cells(i, 1)
isUnique = True

If Not i = cLastRow Then

For j = i + 1 To cLastRow

If thisValue = Cells(j, 1) Then isUnique = False

Next j

End If



If isUnique Then

'output somewhere
Sheet2.Cells(outputRow, 1) = thisValue
outputRow = outputRow + 1


End If
Next i
End Sub


Sub CopyDateRange()

Rows("1:1").Select
Selection.Copy
Sheets("Sheet2").Select
Rows("1:1").Select
ActiveSheet.Paste
End Sub

 

[m m]

thanks tony,

but how do i indicate how many cells to populate? how many intersections
of dates and "items" to fill?

 

[Bob Phillips]

Hi,

Try this (watch wrap around on the formula in the middle)

Sub Unique2()
Dim cLastRow As Long
Dim cLastCol As Long
Dim i As Long
Dim j As Long
Dim thisValue As Long
Dim isUnique As Boolean
Dim outputRow As Long

outputRow = 2

cLastRow = Cells(Rows.Count, "A").End(xlUp).Row
cLastCol = Cells(1, Columns.Count).End(xlToLeft).Column

Rows(1).Copy Destination:=Sheet2.Cells(1, 1)

For i = 2 To cLastRow

If Cells(i, 1).Value <> Cells(i - 1, 1).Value Then
Sheet2.Cells(outputRow, 1).Value = Cells(i, 1).Value
For j = 2 To cLastCol
Sheet2.Cells(outputRow, j).FormulaR1C1 =
"=SUMPRODUCT((Sheet1!R1C2:R1C" & cLastCol & "=Sheet2!R1C)*(Sheet1!R2C1:R" &
cLastRow & "C1=Sheet2!RC1),Sheet1!R2C2:R" & cLastRow & "C" & cLastCol & ")"
Next j
outputRow = outputRow + 1
End If

Next i

End Sub


--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Jim Feaver]

Hello All:

This approach works. It also copies the Date headers and vertical index
numbers.


Sub SumMatrix()
Dim i As Integer, j As Integer
Dim rng As Range, c As Range
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim lLastRow As Long, lSum As Long

Set Sh1 = ThisWorkbook.Worksheets("Sheet1")
Set Sh2 = ThisWorkbook.Worksheets("Sheet2")

Set rng = Sh1.Range("1:1").Find(What:="", Lookat:=xlPart)
lLastRow = Sh1.Cells(Rows.Count, "A").End(xlUp).Row

i = 1
j = 1

For j = 1 To rng.Column - 2
lSum = 0
Sh2.Range("A1").Offset(0, j).Value = Sh1.Range("A1").Offset(0,
j).Value

For i = 1 To Sh1.Range("A" & lLastRow).Value
Sh2.Range("A1").Offset(i, 0).Value = i
lSum = 0
For Each c In Sh1.Range("A2:A" & lLastRow)
If c.Value = i Then
lSum = lSum + c.Offset(0, j).Value
Sh2.Range("A1").Offset(i, j).Value = lSum
End If
Next c
lSum = 0
Next i
Next j

Set Sh1 = Nothing
Set Sh2 = Nothing
Set rng = Nothing
End Sub

Regards,
Jim Feaver

 

[Bob Phillips]

Jim,

May I suggest that my solution has one big advantage over yours (I would say
that<G>?

If another column or row is inserted in the middle of the source data, or a
value is changed, the target data will automatically update without the need
to re-run, as I create formulae, not values.

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[Jim Feaver]

Good point.
Thanks, Bob
Regards,
Jim Feaver

Jim,

May I suggest that my solution has one big advantage over yours (I would say
that<G>?

If another column or row is inserted in the middle of the source data, or a
value is changed, the target data will automatically update without the need
to re-run, as I create formulae, not values.

--

HTH

Bob Phillips
... looking out across Poole Harbour to the Purbecks
(remove nothere from the email address if mailing direct)

 

[m m]

Beautiful Guys
Thank You!

 

[m m]

WAIT but what if the like "items" are not in sequential rows. what if
you add a row at the bottem with item = 1???

 

[Jim Feaver]

Hi:
I modified the code to permit items to appear in any order, blanks as well.
Also, both tables can be positioned anywhere with minimal editing
because all range references are expressed as variables.

I added a Function procedure to for determining the highest item number.

Sub SumMatrix()
Dim c As Range, lngSum As Long
Dim Sh1 As Worksheet, Sh2 As Worksheet
Dim lRow As Long, lCol As Long
Dim i As Integer, j As Integer
Dim numItem As Long
Dim rng1 As Range, rng2 As Range


'edit these Set statements if you rename the worksheet(s)
Set Sh1 = ThisWorkbook.Worksheets("Sheet1")
Set Sh2 = ThisWorkbook.Worksheets("Sheet2")

'Reference ranges marking the top left corner of each table.
'they don't have to be the same
'edit rng1 if you change the location of the raw data table
Set rng1 = Sh1.Range("D15")

'edit rng2 to change the location of the summed table
Set rng2 = Sh2.Range("B10")


lRow = Sh1.Cells(Rows.Count, rng1.Column).End(xlUp).Row
lCol = Sh1.Cells(rng1.Row, Columns.Count).End(xlToLeft).Column

i = 1
j = 1
numItem = MaxItem(rng1, lRow)

For j = 1 To lCol - rng1.Column
lngSum = 0
rng2.Offset(0, j).Value = rng1.Offset(0, j).Value
For i = 1 To numItem
rng2.Offset(i, 0).Value = i
lngSum = 0
For Each c In Range(rng1.Offset(1, 0), rng1.Offset(lRow, 0))
If c.Value = i Then
lngSum = lngSum + c.Offset(0, j).Value
rng2.Offset(i, j).Value = lngSum
End If
Next c
lngSum = 0
Next i
Next j

Set Sh1 = Nothing
Set Sh2 = Nothing
Set rng1 = Nothing
Set rng2 = Nothing

End Sub

Function MaxItem(rRange As Range, lastRow As Long) As Long
Dim rData As Range
Dim c As Range
Dim vMax As Long

Set rData = Range(rRange, rRange.Offset(lastRow, 0))

vMax = 0
For Each c In rData
If c.Value > vMax Then
vMax = c.Value
End If
Next c

MaxItem = vMax
Set rData = Nothing
End Function

Regards,
Jim Feaver