Here's what I've got:[VBA]Option Explicit
Dim Memory1 As Integer
Dim Memory2 As Long
Dim flag As Boolean
Sub PrepareForNextMonth()
Dim ws As Worksheet
Dim i As Integer, j As Integer
Dim Ends
For i = 2 To Worksheets.Count
Set ws = Sheets(i)
ReDim Ends(0)
Memory1 = Month(ws.Cells(3, 1))
Memory2 = 3
Do
If Not IsEmpty(Ends(0)) Then ReDim Preserve Ends(UBound(Ends) + 1)
Ends(UBound(Ends)) = EndOfMonth(ws)
Loop Until flag
For j = 0 To UBound(Ends)
With ws.Cells(Ends(j), 1)
.Offset(, 3).Font.Bold = True
.Offset(, 4) = Format(.Value, "mmm")
.Offset(, 4).Font.Bold = True
.Offset(1, 3).Formula = "=if(" & .Offset(1, 2).Address(False, False) & "="""",""""," & .Offset(1, 2).Address(False, False) & ")"
End With
Next
flag = False
Next
End Sub
Function EndOfMonth(ws As Worksheet) As Long
Dim c As Range
With ws
For Each c In .Range("A" & Memory2 + 1 & ":A" & .Columns("A").End(xlDown).Row)
If c = vbNullString Then
EndOfMonth = Memory2
flag = True
Exit Function
End If
Select Case Month(c)
Case Memory1
Memory1 = Month(c)
Memory2 = c.Row
Case Is > Memory1
EndOfMonth = Memory2
Memory1 = Month(c)
Memory2 = c.Row
Exit Function
End Select
Next
End With
End Function
[/VBA]
A few things:
1.) Since I didn't hear from you before I finished this, instead of inserting an array formula beneath the total, the procedure inserts the simpler IF() statement.
2.) This will not behave well when multiple years are involved in the same workbook. (Since the example you gave is titled "2008.xls", I assumed you had a seperate workbook for each year. Plus, it was easier on me that way. )
3.) It will bold the total, insert the formula, etc. for the last entry on each sheet it looks at. So, just be aware that running this before you've entered the last of the data for your month will mess you up.