I have a 25,000 row spreadsheet that consists of employee
data for a 6-month period, which means the employee
information repeats for many weeks. I need to average
hours per employee which is easy enough using auto
subtotals. However, the user wants the employee
information (such as employee number, etc.) repeated in
the summary record, which it does not, and I then need to
delete all the rows that do not have the average summary
in them. What is the easiest way to do this? I've thought
of several things, but I'm sure I'm looping this code
around more times than I need to. Any help will be
great! Thanks.

Eva,

1. "I then need to delete all the rows that do not have the average
summary in them."

After sub totaling, hide the non-totaled rows using the
"1", "2", "3" buttons at the top left of the sheet. Then using
Edit | Goto | Special (button) | Visible Cells only ...
copy the "visible" rows and paste them on another sheet.

2. "the user wants the employee information
(such as employee number, etc.) repeated in the summary record"

I have VBA code that will add your data to the sub-totaled rows.
Advise if you would like to see it.

Regards,
Jim Cone
San Francisco, CA

"Eva Shanley" wrote in message
...
I have a 25,000 row spreadsheet that consists of employee
data for a 6-month period, which means the employee
information repeats for many weeks. I need to average
hours per employee which is easy enough using auto
subtotals. However, the user wants the employee
information (such as employee number, etc.) repeated in
the summary record, which it does not, and I then need to
delete all the rows that do not have the average summary
in them. What is the easiest way to do this? I've thought
of several things, but I'm sure I'm looping this code
around more times than I need to. Any help will be
great! Thanks.

Eva,

I'd like to take a gander, can you forward the excel
file directly to: ?

Sincerely,

David Fixemer

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

"David Fixemer" wrote in message
...
Eva,
I'd like to take a gander, can you forward the excel
file directly to: ?
Sincerely,
David Fixemer

"Jim Cone" wrote in message
...
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 - XX
' 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
'-------------------------------------------------------------------------------
--------

Another option is to create a PivotTable to summarize the data. Add
Employee Name and ID to the row area, and hours to the data area.
Double-click the Hours button, and choose to Summarize by Average.

After the PivotTable is created, you could copy it, and paste in another
location as Values.

Eva Shanley wrote:
I have a 25,000 row spreadsheet that consists of employee
data for a 6-month period, which means the employee
information repeats for many weeks. I need to average
hours per employee which is easy enough using auto
subtotals. However, the user wants the employee
information (such as employee number, etc.) repeated in
the summary record, which it does not, and I then need to
delete all the rows that do not have the average summary
in them. What is the easiest way to do this? I've thought
of several things, but I'm sure I'm looping this code
around more times than I need to. Any help will be
great! Thanks.


--
Debra Dalgleish
Excel FAQ, Tips & Book List
http://www.contextures.com/tiptech.html