Summing to blank row + 1 help

rcb1 · Jul 29th 2016

Hi all,

I've been browsing these forums for a while -- it is such a wonderful resource. I was able to find some VBA codes that will allow me to add an extra row whenever the word "Transfer" appears and to sum the values below the blank row that was added. I need to adjust this range to include one extra cell after the blank row but can't seem to figure it out. Is it possible to look for the blank row + 1? Also, is it possible to combine this action into one macro, rather than having to run multiple macros to get the result I'm looking for? I've attached a copy of the test document I'm using.

Thanks! I appreciate your insight!

Code

Sub add_row()    Dim x&
    x = Cells(Rows.Count, "B").End(xlUp).Row
    While x <> 0
        If UCase(Cells(x, "B").Value) = UCase("transfer") Then
            Rows(x).Insert
        End If
    x = x - 1
    Wend
End Sub




Sub sum_cells()
    Dim r As Range
    For Each r In Columns("F").SpecialCells(2, 1).Areas
        If r(0).Value = "" Then
            With r(0).Resize(, 1)
                .Formula = "=subtotal(9," & r.Address & ")"
                .EntireRow.Range("a1:bg1").Interior.Color = RGB(255, 255, 153)
            End With
        End If
    Next
End Sub

Display More

wideboydixon · Jul 29th 2016

Re: Summing to blank row + 1 help

Give this a try; it combines both in one:

Code

Public Sub SubtotalAtTransfer()


Dim lastRow As Long
Dim thisRow As Long
Dim toRow As Long


' The last row of data
lastRow = Cells(Rows.Count, 2).End(xlUp).Row


' The row we're processing
thisRow = lastRow


' The row that contains the last value in the subtotal
toRow = lastRow


' Process up to but not including the headers
Do While thisRow > 1
    ' Look for transfer
    If StrComp(Cells(thisRow, 2).Value, "transfer", vbTextCompare) = 0 Then
        ' Insert two new rows here
        Rows(thisRow).Resize(2).Insert xlShiftDown
        
        ' Which moves our total to row done by two
        toRow = toRow + 2
        
        ' Set the formula for the subtotal
        Cells(thisRow + 1, 6).Formula = "=SUBTOTAL(9, F" & CStr(thisRow + 2) & ":F" & CStr(toRow) & ")"
        
        ' Highlight the row in yellow
        Rows(thisRow + 1).Range("A1:BG1").Interior.Color = RGB(255, 255, 153)
        
        ' This previous row is now our new row to total to
        toRow = thisRow - 1
    End If
    
    ' Move up one row
    thisRow = thisRow - 1
Loop


End Sub

Display More

WBD

rcb1 · Jul 29th 2016

Re: Summing to blank row + 1 help

That is beautiful wideboydixon -- thank you!

wideboydixon · Jul 29th 2016

Re: Summing to blank row + 1 help

Quote from rcb1;774705

That is beautiful wideboydixon -- thank you!

You're welcome

WBD

rcb1 · Jul 29th 2016

Re: Summing to blank row + 1 help

Hi wideboydixon, I hope you don't mind me asking one last question, but I was wondering if you might know how to perform two additional tasks on this document:

1. Add "Balance" to the cell above each instance of "transfer" -- e.g. B5, B14, B19, B24, B30 would contain "Balance"
2. If possible, would it also be possible to add a row below the header and add "Balance" and the same sum pattern as the others? (this often doesn't follow the same "transfer" pattern, so it may require an additional line of code)

If this is too much, it is totally understood; however, any insight would be greatly appreciated!

rcb1 · Jul 30th 2016

Re: Summing to blank row

Apologies, I just realized that I had posted this in the wrong section. If someone can move this to Excel VBA / Macros it'd be appreciated.

Aside from this, to help clearly display my problem I've attached another document that includes tabs for the base data ("test"), the post-macro data ("current"), the macro code used ("macro") and the desired outcome ("desired outcome").

Code

Public Sub SubtotalAtTransfer()     
    Dim lastRow As Long
    Dim thisRow As Long
    Dim toRow As Long
     
     ' The last row of data
    lastRow = Cells(Rows.Count, 2).End(xlUp).Row
     
     ' The row we're processing
    thisRow = lastRow
     
     ' The row that contains the last value in the subtotal
    toRow = lastRow
     
     ' Process up to but not including the headers
    Do While thisRow > 1
         ' Look for transfer
        If StrComp(Cells(thisRow, 2).Value, "transfer", vbTextCompare) = 0 Then
             ' Insert two new rows here
            Rows(thisRow).Resize(2).Insert xlShiftDown
             
             ' Which moves our total to row done by two
            toRow = toRow + 2
             
             ' Set the formula for the subtotal
            Cells(thisRow + 1, 6).Formula = "=SUM(F" & CStr(thisRow + 2) & ":F" & CStr(toRow + 2) & ")"
             
             ' Highlight the row in yellow
            Rows(thisRow + 1).Range("A1:BG1").Interior.Color = RGB(255, 255, 153)
             
             ' This previous row is now our new row to total to
            toRow = thisRow - 1
        End If
         
         ' Move up one row
        thisRow = thisRow - 1
    Loop
     
End Sub

Display More

Thanks all, for your help and insight on this!

rcb1 · Jul 30th 2016

Re: Summing to blank row + 1 help

Scratch that, I was able to figure it out. Thanks everyone.

Code

Public Sub BalanceSheetSplitMacro()     
    Dim lastRow As Long
    Dim thisRow As Long
    Dim toRow As Long
     
     ' The last row of data
    lastRow = Cells(Rows.Count, 2).End(xlUp).Row
     
     ' The row we're processing
    thisRow = lastRow
     
     ' The row that contains the last value in the subtotal
    toRow = lastRow
     
     ' Process up to but not including the headers
    Do While thisRow > 1
         ' Look for transfer
        If StrComp(Cells(thisRow, 2).Value, "transfer", vbTextCompare) = 0 Then
             ' Insert two new rows here
            Rows(thisRow).Resize(2).Insert xlShiftDown
             
             ' Which moves our total to row done by two
            toRow = toRow + 2
             
             ' Set the formula for the subtotal
            Cells(thisRow + 1, 6).Formula = "=SUM(F" & CStr(thisRow + 2) & ":F" & CStr(toRow + 2) & ")"
             
             ' Highlight the row in yellow
            Rows(thisRow + 1).Range("A1:AA1").Interior.Color = RGB(255, 255, 153)
            Rows(thisRow + 1).Range("A1:AA1").Font.Bold = True
            Rows(thisRow + 1).Range("$A$1").Value = "Balance"




             
             ' This previous row is now our new row to total to
            toRow = thisRow - 1




        End If
         
         ' Move up one row
        thisRow = thisRow - 1
    Loop




            ' This previous row is now our new row to total to
            Rows("2:2").Select
            Selection.Insert Shift:=xlDown, CopyOrigin:=xlFormatFromLeftOrAbove




            ' Highlight the row in yellow
            Rows("2:2").Range("A1:AA1").Interior.Color = RGB(204, 255, 153)




            ' Set the formula for the subtotal
            Cells(thisRow + 1, 6).Formula = "=SUM(F" & CStr(thisRow + 2) & ":F" & CStr(toRow + 3) & ")"
            Rows(thisRow + 1).Range("A1:AA1").Font.Bold = True
            Rows(thisRow + 1).Range("$A$1").Value = "Current balance"
            
            'Adjust date columns
            Columns("H:H").EntireColumn.AutoFit
            Columns("I:I").EntireColumn.AutoFit




            'Adjust number format to 0.00
            Columns("F:F").Select
            Range("F2").Activate
            Selection.NumberFormat = "0.00"
            
            'Return to cell A1
            Range("A1").Select




End Sub

Display More

Summing to blank row + 1 help

Participate now!

Share

Users Viewing This Thread