Jim Cone said:
David,
Thanks for your interest.
I wrote the code near 4 years ago and now looking it over,
there are a couple things I want to change. Give me a day or two,
and I will forward the code.
Regards,
Jim Cone
San Francisco, CA
'--------------------------------------------------------------
For those who are still reading this, I made some minor changes
to the code and have posted it below - about - 170 lines...
Jim Cone
San Francisco, CA USA
(remove xxx from my email address)
'--------------------------------------------------------------
Option Explicit
' ========================================================
' FillInSubtotalBlanks created on July 24, 2000.
' Modified slightly on Feb 25, 2004
' James Cone, San Francisco, CA - (e-mail address removed)
' Used with an Excel Sub-totaled list to fill in missing data in the rows with
subtotals.
' Only columns within the selection are filled in.
' ==========================================================
Sub FillInSubtotalBlanks()
On Error GoTo InTrouble
If ActiveSheet Is Nothing Then Exit Sub
Application.EnableCancelKey = xlErrorHandler
Dim CantFindMsg As String
Dim ColChoice As String
Dim NoSelection As Boolean
Dim SeeCells As Range
Dim SingleCell As Range
Dim CellsToFind As Range
Dim RowsCount As Long
Const MSG_TITLE As String = " Add Text to Subtotal Rows "
If ActiveSheet.ProtectContents Then
CantFindMsg = "The worksheet must be unprotected. "
ElseIf TypeName(Selection) <> "Range" Then
CantFindMsg = "Please select a cell range. "
ElseIf Selection.Areas.Count > 1 Then
CantFindMsg = "Multiple selections will not work." & vbCr & _
"Select only one area and try again. "
ElseIf Application.Intersect(Selection, ActiveSheet.UsedRange) Is Nothing Then
CantFindMsg = "You must select a cell within a subtotaled list. "
ElseIf Selection.Rows.Count = Rows.Count Then
CantFindMsg = "Selecting an entire column will not work." & vbCr & _
"Make your selection entirely within the sub-totaled list. "
_
& vbCr & "You can also select a single cell within the list."
ElseIf Selection.Count < 3 Then
If Selection.CurrentRegion.HasFormula = False Then
CantFindMsg = " Unable to find subtotaled list. "
Else
Set CellsToFind = Selection.CurrentRegion
End If
Else
On Error Resume Next
Set CellsToFind = Application.Intersect(Selection.EntireRow,
ActiveSheet.UsedRange) _
.SpecialCells(xlCellTypeFormulas)
If Err.Number = 0 Then
On Error GoTo InTrouble
Set CellsToFind = CellsToFind(1).CurrentRegion
Else
On Error GoTo InTrouble
CantFindMsg = " Unable to find subtotals within the selection. "
End If
End If
If Len(CantFindMsg) Then
Application.Cursor = xlDefault
MsgBox CantFindMsg, vbInformation, MSG_TITLE
GoTo AllOver
End If
'THE FINAL LOOP WILL FAIL IF IT TRYS TO FIND CELL ABOVE ROW ONE.
NoSelection = Selection.Count < 3
RowsCount = CellsToFind.Rows.Count
If CellsToFind.Rows(1).Row = 1 Then
If RowsCount > 1 Then
Set CellsToFind = CellsToFind.Offset(1, 0)
Set CellsToFind = CellsToFind.Resize(RowsCount - 1)
RowsCount = RowsCount - 1
End If
End If
'CHECKS FOR A "GRAND" TOTAL ROW AND EXCLUDES IT.
For Each SingleCell In Range(CellsToFind.Rows(RowsCount).Address)
If InStr(SingleCell, "Grand") Then 'Eliminates
GrandTotal row.
Set CellsToFind = CellsToFind.Resize(RowsCount - 1)
Exit For
End If
Next 'SingleCell
'LOOK FOR CELLS WITH SUBTOTAL FORMULAS
CantFindMsg = " Unable to find subtotaled list .."
On Error Resume Next 'Generates an error if
nothing found.
Set CellsToFind = CellsToFind.SpecialCells(xlCellTypeFormulas)
If Err.Number = 0 Then
On Error GoTo InTrouble
For Each SingleCell In CellsToFind
If InStr(SingleCell.Formula, "SUBTOTAL") Then
CantFindMsg = vbNullString
Exit For
End If
Next 'SingleCell
End If
If Len(CantFindMsg) Then
MsgBox CantFindMsg, vbInformation, MSG_TITLE
GoTo AllOver
End If
'FIND VISIBLE CELLS THAT INTERSECT WITH ACTIVECELL COLUMN OR THE SELECTION.
Set SeeCells = CellsToFind.SpecialCells(xlCellTypeVisible)
If NoSelection Then
'CurrentRegion is used
ColChoice = Columns(ActiveCell.Column).Address(False, False)
ColChoice = Left$(ColChoice, 2 + (ActiveCell.Column < 27)) '2 + 0 or
2 + (-1)
Set SeeCells = Application.Intersect(SeeCells.EntireRow,
Columns(ColChoice))
CantFindMsg = "Subtotal rows in column " & ColChoice & " will be filled
in. "
If MsgBox(CantFindMsg, vbOKCancel + vbInformation, MSG_TITLE) = vbCancel
Then _
GoTo AllOver
Else
On Error Resume Next
Set SeeCells = Application.Intersect(SeeCells.EntireRow, Selection)
If Not SeeCells Is Nothing Then
On Error GoTo InTrouble
CantFindMsg = "Subtotal rows in the selection will be filled in. "
If MsgBox(CantFindMsg, vbOKCancel + vbInformation, MSG_TITLE) = vbCancel
Then _
GoTo AllOver
Else
CantFindMsg = "Please note the following and try again:" & vbCr _
& " The selection cannot be hidden." & vbCr _
& " The selection must be within a subtotaled list." &
vbCr _
& " The selection must include rows with subtotals. "
MsgBox CantFindMsg, vbExclamation, MSG_TITLE
GoTo AllOver
End If
End If
'CHECK FOR SINGLE CELL THEN FIND ALL BLANK CELLS.
CantFindMsg = "No blank cells found in subtotaled rows. "
If SeeCells.Count > 1 Then
On Error Resume Next 'Generates an error if
nothing found.
Set SeeCells = SeeCells.SpecialCells(xlCellTypeBlanks)
If Err.Number = 0 Then CantFindMsg = vbNullString
On Error GoTo InTrouble
ElseIf Len(SeeCells) = 0 Then
CantFindMsg = vbNullString
End If
If Len(CantFindMsg) Then
MsgBox CantFindMsg, vbInformation, MSG_TITLE
GoTo AllOver
End If
'ENTER VALUES IN THE BLANK CELLS IN THE SUBTOTAL ROWS.
Application.ScreenUpdating = False
For Each SingleCell In SeeCells
SingleCell.Value = SingleCell(0, 1)
Next
Application.Cursor = xlDefault
If NoSelection Then CantFindMsg = "Complete ..." & vbCr & _
"Text added to column " & ColChoice & ". " Else _
CantFindMsg = "Complete ..." & vbCr & "Text added to the selection. "
Application.ScreenUpdating = True
MsgBox CantFindMsg, vbInformation, MSG_TITLE
AllOver:
On Error Resume Next
Set CellsToFind = Nothing
Set SingleCell = Nothing
Set SeeCells = Nothing
Exit Sub
InTrouble:
Beep
Application.ScreenUpdating = True
If Err.Number <> 18 Then
MsgBox "Error " & Err.Number & " - " & Err.Description & vbCr & _
"Contact the programs author (James Cone) if the problem persists.
", _
vbCritical, MSG_TITLE
End If
Resume AllOver
End Sub
'-------------------------------------------------------------------------------
--------
