Ok.. here is what I have so far.  I have included a zipped excel file
for you to look at.  The code could probably be written tighter.. I am
not the best coder around, just taking a stab at it.

Basically what I have done is this:  I included two macros, one is
called SortByCompany and the other is call SortByWeek

SortByCompany will take your master sheet as break down and filter out
as many companies as you have, so if you have 15 companies, it will
create 15 new sheets with their names on it and their data.

SortByWeek can then be used in either those sheets or in the
mastersheet.  It basically takes the date and break it down into weeks,
each week begins with Saturday and ends with Friday.

The assumtion is that all the entries will be of the same month.
Strange things will happen if they are not..

Here are the codes or you can download the sheet.  You would have to
come to excelforum to download it:
http://www.excelforum.com/showthread...hreadid=572736

Good luck, We can continue to tweak it as you need, I hope this helps
out.

Sub FilterByCompany()

Dim MyUniqueList As Variant, i As Long, sName As String

'stores the ActiveWorkbook.Name so we can return to it
sName = ActiveSheet.Name

'Sort the Data for Filter
Rows("4:2500").Select
Selection.Sort Key1:=Range("A4"), Order1:=xlAscending,
Key2:=Range("D4"), Order2:=xlAscending, Header:=xlGuess,
OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom,
DataOption1:=xlSortNormal, DataOption2:=xlSortNormal

MyUniqueList = UniqueItemList(Range("A4:A2500"), True)

For i = 1 To UBound(MyUniqueList)

'Sort out the Data
Rows("3:2500").Select
Selection.AutoFilter Field:=1, Criteria1:="=" &
MyUniqueList(i)
Cells.Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets.Add 'Create New Sheet
ActiveSheet.Paste 'Paste the Data

'Get month of Data, this is the fastest way I can think of
without going thru a lot of codes...
Range("A1").FormulaR1C1 = "=(TEXT(MONTH(R[3]C[3])*29,
""MMMM""))"

'Rename the Sheet
ActiveSheet.Name = MyUniqueList(i) & " - " & Range("A1")
Range("A1") = Null

'Switch Back to orginal Sheet and deactivate autofilter
Sheets(sName).Activate
Selection.AutoFilter
Range("A1").Select

Next i

End Sub

Sub FilterByWeek()

Dim i As Long, sName As String, mStart As Date, mEnd As Date, mTemp As
Date, mTemp1 As Date

'Set up the Weeks
Range("A1").FormulaR1C1 =
"=(DATE(YEAR(R[3]C[3]),MONTH(R[3]C[3])+1,0))"
mEnd = Range("A1").Value
Range("A1").FormulaR1C1 =
"=(DATE(YEAR(R[3]C[3]),MONTH(R[3]C[3]),1))"
mStart = Range("A1").Value
Range("A1").FormulaR1C1 = Null

mTemp = NthDayOfMonth("Fri", CDate(mStart), 1)
i = 1

Do While mTemp <= mEnd

If i = 1 Then
mTemp1 = mStart
Else
mTemp1 = mTemp - 6
End If

sName1 = ActiveSheet.Name
Rows("3:25").Select
Selection.AutoFilter Field:=4, Criteria1:=">=" & mTemp1,
Operator:=xlAnd, Criteria2:="<=" & mTemp
Cells.Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets.Add
ActiveSheet.Paste
ActiveSheet.Name = sName1 & " - Week " & i
Sheets(sName1).Select
Selection.AutoFilter

i = i + 1
mTemp = mTemp + 7

If mTemp > mEnd Then

sName1 = ActiveSheet.Name
Rows("3:25").Select
Selection.AutoFilter Field:=4, Criteria1:=">=" & mTemp - 6,
Operator:=xlAnd, Criteria2:="<=" & mEnd
Cells.Select
Selection.SpecialCells(xlCellTypeVisible).Select
Selection.Copy
Sheets.Add
ActiveSheet.Paste
ActiveSheet.Name = sName1 & " - Week " & i
Sheets(sName1).Select
Selection.AutoFilter

End If

Loop

End Sub

Private Function UniqueItemList(InputRange As Range, HorizontalList As
Boolean) As Variant
Dim cl As Range, cUnique As New Collection, i As Long, uList() As
Variant
Application.Volatile
On Error Resume Next
For Each cl In InputRange
If cl.Formula <> "" Then
cUnique.Add cl.Value, CStr(cl.Value)
End If
Next cl
UniqueItemList = ""
If cUnique.Count > 0 Then
ReDim uList(1 To cUnique.Count)
For i = 1 To cUnique.Count
uList(i) = cUnique(i)
Next i
UniqueItemList = uList
If Not HorizontalList Then
UniqueItemList = _

Application.WorksheetFunction.Transpose(UniqueItemList)
End If
End If
On Error GoTo 0
End Function

Private Function NthDayOfMonth(Which_Day As String, Which_Date As
String, Occurence As Byte) As Date
Dim i As Integer
Dim iDay As Integer
Dim iDaysInMonth As Integer
Dim FullDateNew As Date
Dim lCount As Long

Which_Date = CDate(Which_Date)

Select Case UCase(Which_Day)
Case "SUN"
iDay = 1
Case "MON"
iDay = 2
Case "TUE"
iDay = 3
Case "WED"
iDay = 4
Case "THU"
iDay = 5
Case "FRI"
iDay = 6
Case "SAT"
iDay = 7
End Select

FullDateNew = DateSerial(Year(Which_Date), Month(Which_Date), 1)

iDaysInMonth = Day(DateAdd("d", -1, DateSerial _
(Year(Which_Date), Month(Which_Date) + 1, 1)))

For i = 0 To iDaysInMonth
If Weekday(FullDateNew + i) = iDay Then
lCount = lCount + 1
End If
If lCount = Occurence Then
NthDayOfMonth = FullDateNew + i
Exit For
End If
Next i

End Function