Sorry for the late reply. Based on your example, try this:
Const MyCol = 2 'column number to check
Sub CheckBlanx()
'Define variables
Dim TotRng As Range, rng As Range, NewGrp As Range
Dim FrstGrpRow As Long, LastGrpRow As Long
Dim LastRow As Long, FrstRec As Boolean
On Error GoTo CBerr
'Set inital values for variables
FrstGrpRow = 0
LastGrpRow = 0
FrstRec = True
'Find the last used cell on the sheet, and select a range
'in the specified column from row 1 through the last row
LastRow = Cells(Rows.Count, MyCol).End(xlUp).Row
Range(Cells(1, MyCol), Cells(LastRow, MyCol)).Select
'Only select blank cells
Selection.SpecialCells(xlCellTypeBlanks).Select
Set TotRng = Selection
'Look at every cell in the selection
For Each rng In TotRng
'Handle the first cell separately
If FrstRec = True Then
Set NewGrp = rng
FrstGrpRow = rng.Row
FrstRec = False
Else
'If the current cell is one row below the previous cell,
'use Union to add it to the NewGrp range.
If rng.Row = LastGrpRow + 1 Then
Set NewGrp = Application.Union(NewGrp, rng)
Else
'The current cell is not contiguous with NewGrp.
'Create subtotal of NewGrp in adjacent column
Call AddSubtotal(FrstGrpRow, LastGrpRow + 1)
Set NewGrp = rng
FrstGrpRow = rng.Row
End If
End If
'Keep track of the last row in NewGrp.
LastGrpRow = rng.Row
Next rng
'Create subtotal for last NewGrp found
Call AddSubtotal(FrstGrpRow, LastGrpRow + 1)
Cleanup:
'Free object variables
Set TotRng = Nothing
Set NewGrp = Nothing
Exit Sub
CBerr:
MsgBox Err.Description, , "CheckBlanx"
GoTo Cleanup
End Sub
Private Sub AddSubtotal(FrstSumRow As Long, LastSumRow As Long)
Cells(LastSumRow, MyCol + 1).Formula = _
"=Subtotal(9," & Cells(FrstSumRow, MyCol - 1).Address & _
":" & Cells(LastSumRow, MyCol - 1).Address & ")"
End Sub
Hope this helps,
Hutch
Steve said:
Thanks for the reply Tom, but the reason I need to do it 1 group at a
time is so I can subtotal the adjacent cells in another column for
each group of empty cells I find (plus 1). I would then place that
subtotal in another column.
For example:
Col A ColB Col C
1.6
1.5
2.7 2/1/2009 5.8
5.5
6.8
4.3 2/2/2009 16.6
---
Steve
I'm not sure why you need to find the empty cells in groups. It sounds like
you just want to find all the empty cells within the used range for a
particular column. The following code will do that:
Sub CheckBlanx()
Dim rng As Range, LastRow As Long
Const MyCol = 1 'column number to process
LastRow = Cells(Rows.Count, MyCol).End(xlUp).Row
Range(Cells(1, MyCol), Cells(LastRow, MyCol)).Select
Selection.SpecialCells(xlCellTypeBlanks).Select
For Each rng In Selection
'do something with adjacent column
Next rng
End Sub
Hope this helps,
Hutch
Steve said:
I am having trouble constructing code which will find groups of empty
cells in a column. The empty cells (all the empty cells do not have
any data or formulas in them) are broken by scattered cells containing
data. I need to be able to isolate a group of empty cells, perform
some calculations on the adjacent cells in the adjacent column, then
isolate the next group of empty cells, do some more calculations on
the adjacent cells in the adjacent column, and so on, all the way to
the last cell containing data in that column.
Thanks in advance for any assistance...
