VBA Code for Summing Multiple Dynamic Ranges in One Column

[FrenchCelt]

Hello,

I have a spreadsheet with a column which lists the total of daily output in various categories (each one in a different row) for multiple people, and I want to be able to sum that output in a row at the bottom of each person's summary. I have a Total row inserted between the bottom row for one person and the top row of the next person, and I have the VBA code looking for the cell with Total in the appropriate row and offsetting to the correct cell where I want the sum to appear, but I don't know how to get it to sum the numbers above that only include the person in question. The number of rows involved is different for each person and will also vary for the same person day to day, so I can't use any constants. The only other way to identify which numbers should be included is that the person's name appears in Column A in every cell I need to sum in Column I, so if I can get it to look first at the row with Total, offset 7 cells to Column I, then look up every row with, say, userA in Column A that has a corresponding value in Column I, and sum them up, then I would be set.

Any help would be appreciated.

 

[jolivanes]

Please don't quote all the posts. Just extra clutter.
Are there empty cells in the data ranges?

 

[FrenchCelt]

Yes, there are empty cells here and there throughout the spreadsheet.

 

[JLGWhiz]

forgot that data starts on row 5. This code assumes that Column B will have a blank cell between groups of data. If not the code fails.

Sub t4()
Dim i As Long, lr As Long, st As Range, fl As Range
With ActiveSheet
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = lr To 5 Step -1
        If LCase(.Cells(i, 1)) = "total" Then
            Set st = .Cells(i, 2).End(xlUp).Offset(, 7)
            If st.Row < 5 Then Set st = .Cells(5, 9)
            Set fl = .Cells(i - 1, 9)
            .Cells(i, 9) = Application.Sum(Range(st, fl))
            .Cells(i, 10) = Application.Sum(Range(st.Offset(, 1), fl.Offset(, 1)))
            .Cells(i, 11) = Application.Sum.Range(st.Offset(, 2), fl.Offset(, 2))
            .Cells(i, 12) = Application.Sum.Range(st.Offset(, 3), fl.Offset(, 3)) / .Cells(i, 11).Value 'This might need work
        End If
        Set st = Nothing
        Set fl = Nothing
    Next
End With
End Sub

 

[FrenchCelt]

I tried using F8 to step through the code, but nothing happened (and there are over 2,000 rows in the spreadsheet, so I didn't bother to keep going once I saw that none of the data was changing after a few iterations).

 

[JLGWhiz]

couple of typos in the Sum statements. I am testing modification.

Now try it

Sub t4()
Dim i As Long, lr As Long, st As Range, fl As Range
With ActiveSheet
    lr = .Cells(Rows.Count, 1).End(xlUp).Row
    For i = lr To 5 Step -1
        If LCase(.Cells(i, 1)) = "total" Then
            Set st = .Cells(i - 1, 2).End(xlUp).Offset(, 7)
            If st.Row < 5 Then Set st = .Cells(5, 9)
            Set fl = .Cells(i - 1, 9)
            .Cells(i, 9) = Application.Sum(Range(st, fl))
            .Cells(i, 10) = Application.Sum(Range(st.Offset(, 1), fl.Offset(, 1)))
            .Cells(i, 11) = Application.Sum(Range(st.Offset(, 2), fl.Offset(, 2)))
            .Cells(i, 12) = Application.Sum(Range(st.Offset(, 3), fl.Offset(, 3))) / .Cells(i, 11).Value 'This might need work
        End If
        Set st = Nothing
        Set fl = Nothing
    Next
End With
End Sub

 

[FrenchCelt]

Still no effect.

 

[JLGWhiz]

Here is what my test setup looks like. Does your sheet look similar to this. Also, when looking for the results, start on the bottom row of your sheet.

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

hdr

hdr

hdr

hdr

hdr

hdr

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

x

2

2

5

5

1

x

x

x

x

x

x

x

x

x

4

2

1

6

1

x

x

x

x

x

x

x

x

x

8

2

5

2

1

x

x

x

x

x

x

x

x

x

5

2

1

4

1

x

x

x

x

x

x

x

x

x

1

1

5

3

1

x

Total

20

9

17

1.176471

x

x

x

x

x

x

x

x

5

1

1

1

1

x

x

x

x

x

x

x

x

x

3

1

4

2

1

x

x

x

x

x

x

x

x

x

4

1

1

4

1

x

x

x

x

x

x

x

x

x

9

1

4

5

1

x

Total

21

4

10

1.2

x

x

x

x

x

x

x

x

6

3

1

3

1

x

x

x

x

x

x

x

x

x

3

3

3

5

1

x

x

x

x

x

x

x

x

x

4

3

3

6

1

x

x

x

x

x

x

x

x

x

1

3

3

4

1

x

x

x

x

x

x

x

x

x

2

3

1

9

1

x

Total

16

15

11

2.454545

<TBODY>
</TBODY>

 

[FrenchCelt]

I asked my IT guy to upload a dummy file to Google Drive if that would help. It's basically a downsized version of the real thing (I included four users instead of the several hundred the real file would have). All the data fields are essentially as I see it on the real spreadsheet. Here is the link:

https://drive.google.com/open?id=1KHI6g7Awnj51lsA_0_hkMcHtWm98dXIx

 

[jolivanes]

If in Post #3 you had changed this

Do Until Cells(j, 9).Value = ""

to this (because of the empty cells)

Do Until Cells(j, 1).Value = ""

and had told us about the last "Overall Total" row, you would have been finished.

Maybe try this.
It should sum columns 9, 10 and 11 and Average columns 12 and 14 for each block of individuals.

Sub Sum_And_Average_Blocks_Of_Same_Values_Multiple_Columns()
    Dim lr As Long, j As Long, lst As Range, a As String, i As Long, ii As Long
    Dim sumArr, avArr
    sumArr = Array(9, 10, 11)
    avArr = Array(12, 14)
    lr = Sheets("Sheet1").Cells(Rows.Count, 1).End(xlUp).Row
    i = 11
    j = 5
    Application.ScreenUpdating = False
    Do Until Cells(j, 1).Value = ""
        a = Cells(j, 1).Value
        Set lst = Range("A:A").Find(a, After:=Cells(1, 1), SearchDirection:=xlPrevious, LookAt:=xlWhole)
            For i = LBound(sumArr) To UBound(sumArr)
                Cells(lst.Row + 1, sumArr(i)).Value = WorksheetFunction.Sum(Range(Cells(j, sumArr(i)), Cells(lst.Row, sumArr(i))))
            Next i
            For ii = LBound(avArr) To UBound(avArr)
                Cells(lst.Row + 1, avArr(ii)).Value = WorksheetFunction.Average(Range(Cells(j, avArr(ii)), Cells(lst.Row, avArr(ii))))
            Next ii
        j = lst.Row + 2
    Loop
    Application.ScreenUpdating = True
End Sub

If you get an error message, you might have to delete the "Overall Total" Row for now. It can be added in later.

 

[JLGWhiz]

This will be my last shot at it. I only provided for total in columns I, J, K and L. I was not sure how you calculated the others. This uses the areas method so you should see any changes at the top of the sheet for this code.

Sub t()
Dim rng As Range, ar As Range, cel As Range
    With ActiveSheet
        Set rng = .Range("B5", .Cells(Rows.Count, 2).End(xlUp))
        For Each ar In rng.SpecialCells(xlCellTypeConstants).Areas
            'MsgBox cel.Address
            Set cel = ar.Columns(1).Cells(1).End(xlDown).Offset(1, 7)
            cel = Application.Sum(.Range(ar.Columns(8).Cells(1), cel.Offset(-1)))
            cel.Offset(, 1) = Application.Sum(.Range(ar.Columns(9).Cells(1), cel.Offset(-1, 1)))
        cel.Offset(, 2) = Application.Sum(.Range(ar.Columns(10).Cells(1), cel.Offset(-1, 2)))
            cel.Offset(, 3) = Application.Sum(.Range(ar.Columns(11).Cells(1), cel.Offset(-1, 3)))
        Next
    End With
End Sub