VBA Formula to Calculate a Range between blank rows and loop

[lichldo]

Please see attached image for sample sheet!

I have data sorted by row H and I have a blank row in between each different group. In that blank row, I need to total the values in that group for columns I through O. I want to be able to run a macro do to this. I know I'll need to set the range (which I'd do $1:$300) and then loop it so that if its blank, then the next cell is the top of the new range but I'm getting stuck of how to do that.

Thanks for any help!

 

[Max1616]

Hello! I think this will accomplish what you're looking for:

Sub Totals()
Dim i As Long
Dim lrow As Long
Dim PrevRow As Long

lrow = Cells(Rows.Count, 1).End(xlUp).Row
PrevRow = 1

For i = 2 To lrow + 1
    If Cells(i, 1) = "" Then
        Range("I" & i) = "=Sum(I" & PrevRow + 1 & ":I" & i - 1 & ")"
        Range("I" & i).Copy
        Range("J" & i & ":O" & i).PasteSpecial xlPasteFormulas
        Application.CutCopyMode = False
        
        PrevRow = i
        
        Range("I" & i & ":O" & i).Font.Bold = True 'You can comment this out if you do not want the total values to be bolded.
        
    End If
    
    
Next i


End Sub

This will automatically determine the last row in your data set, so no need to hard code a range. I also added a line in the code that will bold the new total values so they are easy to see. Feel free to delete that line if you don't want that addition.

I hope this helps!

 

[Fluff]

Another option

Sub lichldo()
   Dim Rng As Range
   
   For Each Rng In Range("H2", Range("H" & Rows.Count).End(xlUp)).SpecialCells(xlConstants).Areas
      With Rng.Offset(Rng.Count, 1).Resize(1, 7)
         .Formula = "=sum(" & Rng.Offset(, 1).Address(0, 0) & ")"
         .Value = .Value
      End With
   Next Rng

End Sub

 

[lichldo]

Hello! I think this will accomplish what you're looking for:

Sub Totals()
Dim i As Long
Dim lrow As Long
Dim PrevRow As Long

lrow = Cells(Rows.Count, 1).End(xlUp).Row
PrevRow = 1

For i = 2 To lrow + 1
    If Cells(i, 1) = "" Then
        Range("I" & i) = "=Sum(I" & PrevRow + 1 & ":I" & i - 1 & ")"
        Range("I" & i).Copy
        Range("J" & i & ":O" & i).PasteSpecial xlPasteFormulas
        Application.CutCopyMode = False
       
        PrevRow = i
       
        Range("I" & i & ":O" & i).Font.Bold = True 'You can comment this out if you do not want the total values to be bolded.
       
    End If
   
   
Next i


End Sub

This will automatically determine the last row in your data set, so no need to hard code a range. I also added a line in the code that will bold the new total values so they are easy to see. Feel free to delete that line if you don't want that addition.

I hope this helps!

That works perfectly. I'm wondering if there is a way to in addition to bold the total values, have it put any number under 50,000 in green text color, and any number over 75,000 in red text color?

 

[lichldo]

That works perfectly. I'm wondering if there is a way to in addition to bold the total values, have it put any number under 50,000 in green text color, and any number over 75,000 in red text color?

Actually I'm running into an issue. I will need to reuse this on new tabs as they get added and then it won't work?

 

[Max1616]

The below code will change the text to green for anything above 50k. This macro should work across multiple worksheets. So I can trouble shoot what's wrong, could you send me a screenshot of:

1. The sheet you are running the macro it on and receiving an error
2. The error message you're getting
3. When you press debug on the error message, send me a screenshot of the code that is highlighted

Sub Totals()
Dim i As Long
Dim lrow As Long
Dim PrevRow As Long
Dim j As Long

lrow = Cells(Rows.Count, 1).End(xlUp).Row
PrevRow = 1

For i = 2 To lrow + 1
    If Cells(i, 1) = "" Then
        Range("I" & i) = "=Sum(I" & PrevRow + 1 & ":I" & i - 1 & ")"
        Range("I" & i).Copy
        Range("J" & i & ":O" & i).PasteSpecial xlPasteFormulas
        Application.CutCopyMode = False
        
        PrevRow = i
        
        Range("I" & i & ":O" & i).Font.Color = 0 'Turn all to black font
        Range("I" & i & ":O" & i).Font.Bold = True 'You can comment this out if you do not want the total values to be bolded.
        
        For j = 9 To 15
            If Cells(i, j) > 50000 Then Cells(i, j).Font.Color = -11489280 'Turn everything > 50k to green font
        Next j
          
    End If
       
Next i


End Sub

 

[lichldo]

The below code will change the text to green for anything above 50k. This macro should work across multiple worksheets. So I can trouble shoot what's wrong, could you send me a screenshot of:

1. The sheet you are running the macro it on and receiving an error
2. The error message you're getting
3. When you press debug on the error message, send me a screenshot of the code that is highlighted

Sub Totals()
Dim i As Long
Dim lrow As Long
Dim PrevRow As Long
Dim j As Long

lrow = Cells(Rows.Count, 1).End(xlUp).Row
PrevRow = 1

For i = 2 To lrow + 1
    If Cells(i, 1) = "" Then
        Range("I" & i) = "=Sum(I" & PrevRow + 1 & ":I" & i - 1 & ")"
        Range("I" & i).Copy
        Range("J" & i & ":O" & i).PasteSpecial xlPasteFormulas
        Application.CutCopyMode = False
       
        PrevRow = i
       
        Range("I" & i & ":O" & i).Font.Color = 0 'Turn all to black font
        Range("I" & i & ":O" & i).Font.Bold = True 'You can comment this out if you do not want the total values to be bolded.
       
        For j = 9 To 15
            If Cells(i, j) > 50000 Then Cells(i, j).Font.Color = -11489280 'Turn everything > 50k to green font
        Next j
         
    End If
      
Next i


End Sub

thanks so much, this is almost perfect! Any way to get it to omit Row 2? It's somehow trying to total the months in the headers, see image

 

[Max1616]

Try this:

Sub Totals()
Dim i As Long
Dim lrow As Long
Dim PrevRow As Long
Dim StartRow As Integer
Dim j As Long

lrow = Cells(Rows.Count, 1).End(xlUp).Row

If Cells(2, 1) = "" Then
    StartRow = 3
    PrevRow = 2
Else
    StartRow = 2
    PrevRow = 1
End

For i = StartRow To lrow + 1
    If Cells(i, 1) = "" Then
        Range("I" & i) = "=Sum(I" & PrevRow + 1 & ":I" & i - 1 & ")"
        Range("I" & i).Copy
        Range("J" & i & ":O" & i).PasteSpecial xlPasteFormulas
        Application.CutCopyMode = False
       
        PrevRow = i
       
        Range("I" & i & ":O" & i).Font.Color = 0 'Turn all to black font
        Range("I" & i & ":O" & i).Font.Bold = True 'You can comment this out if you do not want the total values to be bolded.
       
        For j = 9 To 15
            If Cells(i, j) > 50000 Then Cells(i, j).Font.Color = -11489280 'Turn everything > 50k to green font
        Next j
         
    End If
      
Next i


End Sub