macro to sum each range individually within a single column

**jferguson** · 01-15-2010, 12:44 PM

I have ranges of numbers in column A separated by 2 blank rows. I would like to write a macro that places the sum of each range within the first blank cell above the range of numbers.

For example, there are numerical values within the range A3:A6. I would like to have the sum of A3:A6 placed in A2.

The reason I need the macro is because the ranges vary in length. Some ranges may be 1 row while others contain 50 or more rows. The total number of rows in this sheet is approximately 22,000 (this includes all of the blank rows). By the way, if there is only one row or data I would still like to have it's value placed in the first blank cell above.

I am extremely new to writing macros and apparently lack the knowledge to complete this task without some expert help. If would appreciate any help that I can get.

If there's an existing thread for such an issue please provide the link so that I can hopefully learn.

Thanks,
J

**zeke varg** · 01-15-2010, 02:03 PM

Why use a macro at all? If all your data is in col A, use =IF(ISBLANK(C12),C11,D12+C11) in col B and the total will magically appear above each subsection of data, albeit in col B, not A.

EDIT: The formula assumes your first data entry is in column C, row 11. You have to adjust the references.

**Leith Ross** · 01-15-2010, 02:30 PM

Hello jferguson,

Welcome to the Forum!

This macro will sum the tables and place the sum above the table. Change the starting of "A3" to what your starting cell will be. Copy this code into a standard VBA module.

Code:

Sub SumRanges()

  Dim C As Long
  Dim Cell As Range
  Dim R As Long
  Dim Rng As Range
  Dim RngEnd As Range
  
    Set Rng = Range("A3")
    Set RngEnd = Cells(Rows.Count, Rng.Column).End(xlUp)
    
    R = Rng.Row
      Do
        Set Cell = Cells(R, Rng.Column)
        If Not IsEmpty(Cell) Then
          C = Rng.Column - Cell.CurrentRegion.Column + 1
          Cell.Offset(-1, 0) = WorksheetFunction.Sum(Cell.CurrentRegion.Columns(C))
          R = R + Cell.CurrentRegion.Columns(C).Rows.Count
        Else
          R = R + 1
        End If
      Loop Until R > RngEnd.Row
      
End Sub

**mikerickson** · 01-15-2010, 04:27 PM

This should do what you want

Code:

Sub test()
    Dim filledCells As Range, oneArea As Range

    On Error Resume Next
    With Range("A:A"): Rem adjust
        Set filledCells = .SpecialCells(xlCellTypeConstants)
        Set filledCells = .SpecialCells(xlCellTypeFormulas)
        Set filledCells = Application.Union(filledCells, .SpecialCells(xlCellTypeConstants))
    On Error GoTo 0
    End With

    For Each oneArea In filledCells.Areas
        With oneArea
            If 1 < .Row Then
                .Offset(-1, 0).Cells(1, 1).FormulaR1C1 = "=SUM(" & oneArea.Address(, , xlR1C1) & ")"
            End If
        End With
    Next oneArea
End Sub

**PMO** · 01-16-2010, 07:59 AM

Hello,

Another way to

1) create a sheet named "test" and put the numbers in column "A"
2) copy the following code in a standard module

Code:

'### Adapt the constants ###
Const NAME_SHEET_SOURCE As String = "test"
Const CELL_FORMULA_BOLD As Boolean = True
Const CELL_FORMULA_INTERIOR_COLOR As Long = vbCyan  'vbBlue, vbCyan,vbGreen,vbMagenta,vbRed,vbWhite,vbYellow
'###########################

Sub SumEachRange()
Dim S As Worksheet
Dim R As Range
Dim R2 As Range
Dim var
Dim i&
Dim j&
Dim T()
Dim cpt&
Sheets(NAME_SHEET_SOURCE).Copy After:=Sheets(NAME_SHEET_SOURCE)
Set S = ActiveSheet
Do Until S.[a1] <> ""
  S.Rows(1).Delete
Loop
  '--- Vérifie si il y a au moins 2 lignes vides ---
Set R = S.Range("a1:a" & S.[a65536].End(xlUp).Row & "")
var = R
For i& = 1 To UBound(var, 1)
  Set R = S.Range("a" & i& & "").CurrentRegion
  j& = j& + R.Rows.Count
  If i& = 1 Then j& = j& + 1
  If j& > UBound(var, 1) Or j& + 2 > UBound(var, 1) Then Exit For
  If var(j& + 2, 1) <> "" Then
    cpt& = cpt& + 1
    ReDim Preserve T(1 To cpt&)
    T(cpt&) = j&
  End If
  Do
    j& = j& + 1
  Loop Until var(j&, 1) <> ""
  i& = j& - 1
Next i&
  '--- Ajout de lignes pour obtenir 2 lignes vides consécutives ---
For i& = UBound(T) To 1 Step -1
  S.Rows(T(i&)).Insert
Next i&
S.Rows(1).Insert
S.Rows(1).Insert
  '--- Ajout des formules ---
Set R = S.Range("a1:a" & S.[a65536].End(xlUp).Row & "")
var = R
For i& = 3 To UBound(var, 1)
  j& = 0
  Set R = S.Range("a" & i& & "").CurrentRegion
  Set R2 = S.Range("a" & i& - 1 & "")
  R2.Formula = "=SUM(" & R.Address(False, False, xlA1) & ")"
  R2.Font.Bold = True
  If CELL_FORMULA_INTERIOR_COLOR = vbWhite Then
    R2.Interior.ColorIndex = xlNone
  Else
    R2.Interior.Color = CELL_FORMULA_INTERIOR_COLOR
  End If
  i& = i& + R.Rows.Count
  If i& > UBound(var, 1) Then Exit For
  Do Until var(i&, 1) <> ""
    i& = i& + 1
  Loop
  i& = i& - 1
Next i&
End Sub

Adapt any constants identified by # # #

The results appear in a new sheet.

Best regards.

**yodzak** · 04-16-2010, 01:05 PM

Hello,
This is a great forum. This is my first post. I saw the answer to the following thread

http://www.excelforum.com/excel-prog...le-column.html

I am interested in this answer, but I need the total a the bottom of each range that is summed up. Can anyone help me with this.

Thanks,
yodzak

**PMO** · 04-16-2010, 01:56 PM

Hello,

Try this code

Code:

'### Adapt the constants ###
Const NAME_SHEET_SOURCE As String = "test"
Const CELL_FORMULA_BOLD As Boolean = True
Const CELL_FORMULA_INTERIOR_COLOR As Long = vbCyan  'vbBlue, vbCyan,vbGreen,vbMagenta,vbRed,vbWhite,vbYellow
'###########################

Sub SumEachRange()
Dim S As Worksheet
Dim R As Range
Dim R2 As Range
Dim BigR As Range
Dim var
Dim i&
Dim j&
Dim T()
Dim cpt&
Sheets(NAME_SHEET_SOURCE).Copy After:=Sheets(NAME_SHEET_SOURCE)
Set S = ActiveSheet
Do Until S.[a1] <> ""
  S.Rows(1).Delete
Loop
  '--- Vérifie si il y a au moins 2 lignes vides ---
Set R = S.Range("a1:a" & S.[a65536].End(xlUp).Row & "")
var = R
For i& = 1 To UBound(var, 1)
  Set R = S.Range("a" & i& & "").CurrentRegion
  j& = j& + R.Rows.Count
  If i& = 1 Then j& = j& + 1
  If j& > UBound(var, 1) Or j& + 2 > UBound(var, 1) Then Exit For
  If var(j& + 2, 1) <> "" Then
    cpt& = cpt& + 1
    ReDim Preserve T(1 To cpt&)
    T(cpt&) = j&
  End If
  Do
    j& = j& + 1
  Loop Until var(j&, 1) <> ""
  i& = j& - 1
Next i&
  '--- Ajout de lignes pour obtenir 2 lignes vides consécutives ---
For i& = UBound(T) To 1 Step -1
  S.Rows(T(i&)).Insert
Next i&
S.Rows(1).Insert
S.Rows(1).Insert
  '--- Ajout des formules ---
Set R = S.Range("a1:a" & S.[a65536].End(xlUp).Row & "")
var = R
For i& = 3 To UBound(var, 1)
  j& = 0
  Set R = S.Range("a" & i& & "").CurrentRegion
  Set R2 = S.Range("a" & i& - 1 & "")
  R2.Formula = "=SUM(" & R.Address(False, False, xlA1) & ")"
  If BigR Is Nothing Then
    Set BigR = R2
  Else
    Set BigR = Application.Union(BigR, R2)
  End If
  R2.Font.Bold = True
  If CELL_FORMULA_INTERIOR_COLOR = vbWhite Then
    R2.Interior.ColorIndex = xlNone
  Else
    R2.Interior.Color = CELL_FORMULA_INTERIOR_COLOR
  End If
  i& = i& + R.Rows.Count
  If i& > UBound(var, 1) Then Exit For
  Do Until var(i&, 1) <> ""
    i& = i& + 1
  Loop
  i& = i& - 1
Next i&
Set R = S.Range("a" & S.[a65536].End(xlUp).Row + 3 & "")
R.Formula = "=SUM(" & BigR.Address(False, False, xlA1) & ")"
R.Interior.ColorIndex = 4
R.Font.Bold = True
End Sub

Best regards.

PMO
Patrick Morange