VBA Sum Dynamic Range

[rlsublime]

I am trying to sum a dynamic range. I want to look for the second non blank cell in a row range and sum all values in that range and then look through all specified columns. Thanks

[Leith Ross]

Hello rlsublime,

The description of your problem is vague. You should post your workbook. It will help you get answers to your questions faster and provide you with more accurate solutions.

[rlsublime]

Basically, the code below is what I have so far. the first for statement will take the first non blank value in the row range and I am trying to get the second statement to sum all values in the row range after the first value. Currently, the second FOR statement will return the first correct value, but i want it to keep continuing and sum the rest of the values in the row range until the last non blank value. I know it is close but not sure how to add the sum formula to the code below.

So in the brief sample below, I am trying to get it to sum 6 and 8, but not 3 (and then 2 and 3 and 4 but not 1)

A B C d
3 6 8
1 2 3 4

Sub FindFirstNonEmptyCell()
Dim i, j, k As Integer 'i = row number, j = collumn number
    For i = 3 To 20000 'replace '1 and 2' to the desires range
        For j = 4 To 256 'or 16384 in Excel2007
            If Not IsEmpty(Cells(i, j)) Then
                Cells(i, j).Copy Sheets(2).Cells(i, 1) 'the first value will be copied to sheet 2
                Exit For
            End If
        Next
        For j = 4 To 256 'or 16384 in Excel2007
            If Not IsEmpty(Cells(i, j)) Then
                Cells(i, j + 1).Copy Sheets(2).Cells(i, 2) 'the first value will be copied to sheet 2
                Exit For
            End If
        Next
    Next
End Sub

[Leith Ross]

Hello rlsublime,

This macro code is quite different from yours. It relies on exploiting the properties and methods of a Range object to sum each row and transfer it to the destination. I have included comments to explain the macro. Let me know if you have any problems.

Sub SumRows()

    Dim Cell As Range
    Dim DstRng As Range
    Dim r As Long
    Dim RngEnd As Range
    Dim RowSum As Double
    Dim SrcRng As Range
    
        Set SrcRng = Worksheets("Sheet2").Range("D3")
        Set DstRng = Worksheets("Sheet3").Range("A2")
        
          ' Fimd the last entry in the first column of the Source.
            Set RngEnd = SrcRng.Parent.Cells(Rows.Count, SrcRng.Column).End(xlUp)
            
          ' The Source Range is the First Column of the data to be summed.
            Set SrcRng = SrcRng.Resize(RngEnd.Row - SrcRng.Row + 1)
            
              ' Sum column 2 to the Last Column in each row of the Source Range.
                For Each Cell In SrcRng
                
                  ' Find the column of the last contiguous cell in the row.
                    LastCol = Cell.End(xlToRight).Column
                    
                  ' Sum the columns, except the first, in the row
                    RowSum = Application.Sum(Cell.Offset(0, 1).Resize(1, LastCol - Cell.Column))
                    
                  ' Copy the sum to the Destination range
                    DstRng.Offset(r, 0) = RowSum
                  ' Increment the row counter for the Destination rnage.
                    r = r + 1
                    
                Next Cell
    
End Sub

[rlsublime]

Thanks. However, the code did not work as I expected. I have attached a sample workbook. Column B is where I am trying to populate the values. In row 3 for example, I want it to look at cell E3, see that it has a value and then move to F3 and sum everything from F3 to X3. In row 10, I want it to sum everything from H10 to X10. all this will be based off a pivot table so the range will always be dynamic. Thanks in advance for the help.

[HSV]

These conditions I kept me.

In row 3 for example, I want it to look at cell E3, see that it has a value and then move to F3 and sum everything from F3 to X3. In row 10, I want it to sum everything from H10 to X10.

[rlsublime]

Thanks Leith! This definitely solved it. One more related question regarding the code below. For i below, how would I replace the value 10 to instead find the
last non blank value in column D and keep filling i till the end?Thanks

Sub FindFirstNonEmptyCell()
Dim i, j, k As Integer 'i = row number, j = collumn number
    For i = 3 To 10 'replace '1 and 2' to the desires range
        For j = 5 To 256 'or 16384 in Excel2007
            If Not IsEmpty(Cells(i, j)) Then
                Cells(i, j).Copy Sheets(2).Cells(i, 1) 'the first value will be copied to sheet 2
                Exit For
            End If
        Next
    Next
    
End Sub

[Leith Ross]

Hello rlsublime,

I have most of the macro written. Could you provide me with a few more examples of rows to be summed? Two samples really isn't enough to confirm my test results.

[rlsublime]

I am not sure if I entered the code correctly, but it did not sum anything but simply inserted the first value in the cell. What should I enter in the source range if the source range is dynamic? Thanks

[rlsublime]

i think it is because there are blank cells in the range, it stops at a blank cell. If there are zeros, it continues. Is there a way to include blank cells until the second last value in the range. In the spreadsheet I attached, I am trying to sum all values after the first non blank value in the rows and have it stop before the grand total. Pre-money is the first non blank value and I have wirtten code that will extract this value. Post-money is the sum of all values after pre-money up until the grand total. Hope this makes more sense.

[Leith Ross]

Hello rlsublime,

That explanation helps. I do have couple of new questions. Is pre-money always the first date column? In your workbook this is column "E". Or is it the first non-empty cell in the row that is to be summed?

[HSV]

Maybe:

Sub hsv()
Dim i As Long
 For i = 3 To Cells(Rows.Count, 2).End(xlUp).Row
 Cells(i, 25) = WorksheetFunction.Sum(Range(Cells(i, 5), Cells(i, 24))) _
- WorksheetFunction.Sum(Range(Cells(i, 4), Cells(i, 24)).Find("*"))
   Next
End Sub

[rlsublime]

Hello Leith: Correct, pre-monty is always the first non blank date column so it could start in any column. Post money is the sum of the range after pre-money. It includes every value after pre-money and should even include blanks in the sum and should stop summing before the grand total column. Also, the grand total column will not always be in col Y and is also dynamic.

Hello HSV: Thanks for the code, unfortunately, when I entered this for the attached spreadsheet, it did not seem to do anything. Could you please clarify?

Thanks

[Leith Ross]

Hello rlsublime,

This macro is designed to handle a dynamic output as long as the following hold true:
1) Row 2 is the header row.
2) The dates in row 2 are contiguous cells.
3) The data always starts in row 3.

The macro code below has been added to the attached workbook.

Sub SumRows()

    Dim DateCell As Range
    Dim DstRng As Range
    Dim LastCol As Long
    Dim r As Long
    Dim Rng As Range
    Dim RngEnd As Range
    Dim Row As Range
    Dim SumRng As Range
    Dim Wks As Worksheet
    
         Set Wks = Worksheets("Sheet1")
         
         Set Rng = Wks.Range("D2")
         
       ' Cell where the first sum will be copied to.
         Set DstRng = Wks.Range("B3")
         
       ' Find the last cell with data.
         Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
         
       ' Check there is data on the worksheet.
         If RngEnd.Row < Rng.Row Then Exit Sub
         
       ' Expand the range to the last row.
         Set Rng = Wks.Range(Rng, RngEnd)
         
       ' Find the last column with a header.
         LastCol = Wks.Cells(2, Columns.Count).End(xlToLeft).Column
         
       ' Check there is data.
         If LastCol <= Rng.Column Then Exit Sub
         
         Set Rng = Rng.Resize(ColumnSize:=LastCol - Rng.Column + 1)
         
          ' Setup to search for dates.
            With Application.FindFormat
                .Clear
                .NumberFormat = "m/d/yyyy"
            End With
            
          ' Find the First Date.
            Set DateCell = Rng.Rows(1).Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlNext, False, False, True)
            If Not DateCell Is Nothing Then FirstAddx = DateCell.Address Else Exit Sub
        
          ' The sum range is all cells with dates for column headers.
            Do While Not DateCell Is Nothing
                c = c + 1
                Set DateCell = Rng.Rows(1).Cells.Find("*", DateCell, xlValues, xlWhole, xlByColumns, xlNext, False, False, True)
                If DateCell.Address = FirstAddx Then Exit Do
            Loop
            
              ' Start 1 one row below the column headers.
                Set SumRng = DateCell.Offset(1, 0).Resize(Rng.Rows.Count - 1, c)
            
                LastCol = SumRng.Columns(SumRng.Columns.Count).Column
                
                For Each Row In SumRng.Rows
                    On Error Resume Next
                      ' Find the first non empty cell in the row.
                        c = Row.Find("*", Row.Cells(1, 1), xlValues, xlWhole, xlByColumns, xlNext, False).Column
                        
                      ' If the row is empty then an error will occur.
                        If Err = 0 Then
                          ' Find the cells after the first non empty cell to the end of cells to be summed.
                            Set Row = Intersect(Row, Range(Columns(c), Columns(LastCol)))
                            
                          ' Sum the cells in the row and copy the sum to column "B".
                            If Not Row Is Nothing Then DstRng.Offset(r, 0) = Application.Sum(Row)
                            r = r + 1
                        End If
                    On Error GoTo 0
                Next Row
            
End Sub

[rlsublime]

Thanks Leith. This is very close.

1) Row 2 will always be the header row
2)the dates will be contiguous
3)data will always start in row 3

The only current issue is that there are some values that start in column M. Those values will be the pre-money and the others from N onwards will be the post-money. for values that start in H column, everything from I onwards will be the post money and will need to be summed. Currently, it works for values that start after column E but not for values that start in M. Thanks for your help

[Leith Ross]

Hello rlsublime,

I am not really following you on the column "M" piece. Does this mean if everything from columns "E" to "K" are empty, and there are values in "L" and "M" then sum from "M" to the end?

[rlsublime]

Yes, you are correct!

[Leith Ross]

Hello rlsublime,

This change to macro should do it. The change is in red font...

Sub SumRows()

    Dim DateCell As Range
    Dim DstRng As Range
    Dim LastCol As Long
    Dim r As Long
    Dim Rng As Range
    Dim RngEnd As Range
    Dim Row As Range
    Dim SumRng As Range
    Dim Wks As Worksheet
    
         Set Wks = Worksheets("Sheet1")
         
         Set Rng = Wks.Range("D2")
         
       ' Cell where the first sum will be copied to.
         Set DstRng = Wks.Range("B3")
         
       ' Find the last cell with data.
         Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
         
       ' Check there is data on the worksheet.
         If RngEnd.Row < Rng.Row Then Exit Sub
         
       ' Expand the range to the last row.
         Set Rng = Wks.Range(Rng, RngEnd)
         
       ' Find the last column with a header.
         LastCol = Wks.Cells(2, Columns.Count).End(xlToLeft).Column
         
       ' Check there is data.
         If LastCol <= Rng.Column Then Exit Sub
         
         Set Rng = Rng.Resize(ColumnSize:=LastCol - Rng.Column + 1)
         
          ' Setup to search for dates.
            With Application.FindFormat
                .Clear
                .NumberFormat = "m/d/yyyy"
            End With
            
          ' Find the First Date.
            Set DateCell = Rng.Rows(1).Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlNext, False, False, True)
            If Not DateCell Is Nothing Then FirstAddx = DateCell.Address Else Exit Sub
        
          ' The sum range is all cells with dates for column headers.
            Do While Not DateCell Is Nothing
                c = c + 1
                Set DateCell = Rng.Rows(1).Cells.Find("*", DateCell, xlValues, xlWhole, xlByColumns, xlNext, False, False, True)
                If DateCell.Address = FirstAddx Then Exit Do
            Loop
            
              ' Start 1 one row below the column headers.
                Set SumRng = DateCell.Offset(1, 0).Resize(Rng.Rows.Count - 1, c)
            
                LastCol = SumRng.Columns(SumRng.Columns.Count).Column
                
                For Each Row In SumRng.Rows
                    On Error Resume Next
                      ' Find the first non empty cell in the row.
                        c = Row.Find("*", Row.Cells(1, 1), xlValues, xlWhole, xlByColumns, xlNext, False).Column
                        
                      ' If the row is empty then an error will occur.
                        If Err = 0 Then
                          ' Find the cells after the first non empty cell to the end of cells to be summed.
                            If c < 12 Then
                                Set Row = Intersect(Row, Range(Columns(c), Columns(LastCol)))
                            Else
                                Set Row = Intersect(Row, Rnage.Columns(c + 1), Columns(LastCol))
                            End If
                            
                          ' Sum the cells in the row and copy the sum to column "B".
                            If Not Row Is Nothing Then DstRng.Offset(r, 0) = Application.Sum(Row)
                            r = r + 1
                        End If
                    On Error GoTo 0
                Next Row
            
End Sub

[rlsublime]

Thanks! I made the exact code change as you listed, however, that did not seem to change the results. Please advise. thanks

[Leith Ross]

Hello rlsublime,

In that case, I need a few rows from the workbook where the errors occur and the expected results.

[rlsublime]

For example, in the below sample, only 1 and 8 should sum. The code works when there is a value in E column(For eg when 1 is seen, 2 and 3 will sum. but it is still not working when there are null values until L in the below sample. Hope this helps

E F G H I J K L M N O P 
              5 1       8
1 2 3

[Leith Ross]

Hello rlsublime,

Sorry about that, there was a typo in the added code and the On Error statement hide it. The error was in the Set statement in the Else section. Range was misspelled as Rnage. The code should read...

                            If c < 12 Then
                                Set Row = Intersect(Row, Range(Columns(c), Columns(LastCol)))
                            Else
                                Set Row = Intersect(Row, Range(Columns(c + 1), Columns(LastCol)))
                            End If

[rlsublime]

thanks, it did work when those values started in the 12th columns as listed in the code above. What about if the start in the 11th or 10th or 9th or 8th or 20th or 25th so on and so forth. Can we set the 12 to a dynamic value, because it did not work for values that started in column G or Column H. It only worked for values that started in column E and column L. I have code to extract the first pre-money value. What if we look at the premoney value which will be in column A and then find it in the row and sum the range after it?

[rlsublime]

Yes, you are correct!

[Leith Ross]

Hello rlsublime,

This change should solve the problem. Here is the updated code in its entirety. As before, the change appears in red font.

Sub SumRows()

    Dim DateCell As Range
    Dim DstRng As Range
    Dim LastCol As Long
    Dim r As Long
    Dim Rng As Range
    Dim RngEnd As Range
    Dim Row As Range
    Dim SumRng As Range
    Dim Wks As Worksheet
    
         Set Wks = Worksheets("Sheet1")
         
         Set Rng = Wks.Range("D2")
         
       ' Cell where the first sum will be copied to.
         Set DstRng = Wks.Range("B3")
         
       ' Find the last cell with data.
         Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
         
       ' Check there is data on the worksheet.
         If RngEnd.Row < Rng.Row Then Exit Sub
         
       ' Expand the range to the last row.
         Set Rng = Wks.Range(Rng, RngEnd)
         
       ' Find the last column with a header.
         LastCol = Wks.Cells(2, Columns.Count).End(xlToLeft).Column
         
       ' Check there is data.
         If LastCol <= Rng.Column Then Exit Sub
         
         Set Rng = Rng.Resize(ColumnSize:=LastCol - Rng.Column + 1)
         
          ' Setup to search for dates.
            With Application.FindFormat
                .Clear
                .NumberFormat = "m/d/yyyy"
            End With
            
          ' Find the First Date.
            Set DateCell = Rng.Rows(1).Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlNext, False, False, True)
            If Not DateCell Is Nothing Then FirstAddx = DateCell.Address Else Exit Sub
        
          ' The sum range is all cells with dates for column headers.
            Do While Not DateCell Is Nothing
                c = c + 1
                Set DateCell = Rng.Rows(1).Cells.Find("*", DateCell, xlValues, xlWhole, xlByColumns, xlNext, False, False, True)
                If DateCell.Address = FirstAddx Then Exit Do
            Loop
            
              ' Start 1 one row below the column headers.
                Set SumRng = DateCell.Offset(1, 0).Resize(Rng.Rows.Count - 1, c)
            
                LastCol = SumRng.Columns(SumRng.Columns.Count).Column
                
                For Each Row In SumRng.Rows
                    On Error Resume Next
                      ' Find the first non empty cell in the row.
                        c = Row.Find("*", Row.Cells(1, 1), xlValues, xlWhole, xlByColumns, xlNext, False).Column
                        
                      ' If the row is empty then an error will occur.
                        If Err = 0 Then
                          ' Find the cell to the right of the first non empty cell to the end of cells to be summed.
                            Set Row = Intersect(Row, Range(Columns(c + 1), Columns(LastCol)))
                            
                          ' Sum the cells in the row and copy the sum to column "B".
                            If Not Row Is Nothing Then DstRng.Offset(r, 0) = Application.Sum(Row)
                            r = r + 1
                        End If
                    On Error GoTo 0
                Next Row
            
End Sub

[Leith Ross]

Hello rlsublime,

AAAHHHHH! I can't believe I forgot to exclude the first column dynamically! Here is the change to the If statement to ignore the first column in the Sum Range.

                          ' Find the cell to the right of the first non empty cell to the end of cells to be summed.
                            If c = SumRng.Column + 1 Then
                                Set Row = Intersect(Row, Range(Columns(c), Columns(LastCol)))
                            Else
                                Set Row = Intersect(Row, Range(Columns(c + 1)), Columns(LastCol))
                            End If

[HSV]

Sub hsv_2()
Dim i As Long, c As Range
 With Sheets(1)
  For i = 3 To .Cells(Rows.Count, 4).End(xlUp).Row - 1
   Set c = .Range(.Cells(i, 4), .Cells(i, Columns.Count)).Find("*")
     If c.Column > 4 Then
  Sheets(2).Cells(i, 1) = c
     End If
   Next i
 End With
  With Sheets(2)
    .Cells(Rows.Count, 1).End(xlUp).Offset(1) = WorksheetFunction.Sum(.Columns(1))
  End With
End Sub

[Leith Ross]

Hello rlsublime,

If I understand what you want then if a cell is not empty then start summing from 1 cell to the right of it till the end of the summing range. Would that be a correct assumption?

[rlsublime]

Below is the code that I have to search for pre-money and return it in A column

Sub FindFirstNonEmptyCell()
Dim i, j, k As Integer 'i = row number, j = collumn number
    For i = 3 To 10 'replace '1 and 2' to the desires range
        For j = 5 To 256 'or 16384 in Excel2007
            If Not IsEmpty(Cells(i, j)) Then
                Cells(i, j).Copy Sheets(2).Cells(i, 1) 'the first value will be copied to sheet 2
                Exit For
            End If
        Next
    Next
    
End Sub

[rlsublime]

I think we are close. It did not work in a case where there were 2 columns with values, a few blank columns and then data. I have attached a sample workbook with the code and output values. I was referring to row 3,4 8,9 etc. (when it is in that format,the summing is incorrect.)Thanks

[Leith Ross]

Hello rlsublime,

Okay, this should be the final version. I have stepped through the macro and compared the results by summing the individual rows by hand. The macro has been added to the attached workbook.

Sub SumRows()

    Dim DateCell As Range
    Dim DstRng As Range
    Dim LastCol As Long
    Dim r As Long
    Dim Rng As Range
    Dim RngEnd As Range
    Dim Row As Range
    Dim SumRng As Range
    Dim Wks As Worksheet
    
         Set Wks = Worksheets("Sheet1")
         
         Set Rng = Wks.Range("D2")
         
       ' Cell where the first sum will be copied to.
         Set DstRng = Wks.Range("B3")
         
       ' Find the last cell with data.
         Set RngEnd = Wks.Cells(Rows.Count, Rng.Column).End(xlUp)
         
       ' Check there is data on the worksheet.
         If RngEnd.Row < Rng.Row Then Exit Sub
         
       ' Expand the range to the last row.
         Set Rng = Wks.Range(Rng, RngEnd)
         
       ' Find the last column with a header.
         LastCol = Wks.Cells(2, Columns.Count).End(xlToLeft).Column
         
       ' Check there is data.
         If LastCol <= Rng.Column Then Exit Sub
         
         Set Rng = Rng.Resize(ColumnSize:=LastCol - Rng.Column + 1)
         
          ' Setup to search for dates.
            With Application.FindFormat
                .Clear
                .NumberFormat = "m/d/yyyy"
            End With
            
          ' Find the First Date.
            Set DateCell = Rng.Rows(1).Cells.Find("*", , xlValues, xlWhole, xlByColumns, xlNext, False, False, True)
            If Not DateCell Is Nothing Then FirstAddx = DateCell.Address Else Exit Sub
        
          ' The sum range is all cells with dates for column headers.
            Do While Not DateCell Is Nothing
                c = c + 1
                Set DateCell = Rng.Rows(1).Cells.Find("*", DateCell, xlValues, xlWhole, xlByColumns, xlNext, False, False, True)
                If DateCell.Address = FirstAddx Then Exit Do
            Loop
            
              ' Start 1 one row below the column headers.
                Set SumRng = DateCell.Offset(1, 0).Resize(Rng.Rows.Count - 1, c)
            
                LastCol = SumRng.Columns(SumRng.Columns.Count).Column
                
                For Each Row In SumRng.Rows
                   'On Error Resume Next
                      ' Find the first non empty cell in the row.
                        c = Row.Find("*", Row.Cells(1, 1), xlValues, xlWhole, xlByColumns, xlNext, False).Column
                        
                      ' If the row is empty then an error will occur.
                        If Err = 0 Then
                          ' Find the cell to the right of the first non empty cell to the end of cells to be summed.
                            If c = SumRng.Column + 1 Then
                                Set Row = Wks.Range(Cells(Row.Row, c), Cells(Row.Row, LastCol))
                            Else
                                If c + 1 < LastCol Then
                                    Set Row = Wks.Range(Cells(Row.Row, c + 1), Cells(Row.Row, LastCol))
                                End If
                            End If
                                
                        End If
                        
                  ' Sum the cells in the row and copy the sum to column "B".
                    If Not Row Is Nothing Then DstRng.Offset(r, 0) = Application.Sum(Row) Else DstRng.Offset(r, 0) = 0
                    
                  ' increment the row counter.
                    r = r + 1
                    On Error GoTo 0
                Next Row
            
End Sub

[rlsublime]

that code change fixed the first issue in my last post, but it undid the summing that was correct with the other rows/values. Thanks

[Leith Ross]

Hello rlsublime,

I am confused. What are the summing rules again?

[rlsublime]

if a cell is not empty then start summing from 1 cell to the right of it till the end of the summing range. It should include null values and non null values.

[Leith Ross]

Hello rlsublime,

The change below starts at the bottom of column "D" and moves up until it finds a cell with data. It then returns the row number for that cell.

Sub FindFirstNonEmptyCell()
Dim i, j, k As Integer 'i = row number, j = collumn number
    For i = 3 To Cells(Rows.Count, "D").End(xlUp).Row   'replace '1 and 2' to the desires range
        For j = 5 To 256 'or 16384 in Excel2007
            If Not IsEmpty(Cells(i, j)) Then
                Cells(i, j).Copy Sheets(2).Cells(i, 1) 'the first value will be copied to sheet 2
                Exit For
            End If
        Next
    Next
    
End Sub

[rlsublime]

Thanks! There is one more thing that I noticed. The last values in A and B column should be the sumof all the values. Right now it is simply returning the values based on the code. The code below selects the correct range, but how would I sum the selected range in the last cell with a value? Thanks

Sub Macro1()
'    Range("A3").Select
    Range(Selection, Selection.End(xlDown).Offset(-1, 0)).Select
End Sub