Hi ET,

OK, something like this?

Sub Test()
    Dim wsData As Worksheet
    Dim rngContracts As Range, rngUnique As Range, rngCell As Range, rngCopy As Range
    Dim strFName As String
    Dim wbkContract As Workbook
    Const strDir As String = "C:\Contracts\"
Set wsData = ThisWorkbook.Worksheets("Time Data")
    'establish a reference to the data sheet
Application.ScreenUpdating = False
With wsData
.Columns("A:H").Sort _
            Key1:=Range("D2"), Order1:=xlDescending, Header:=xlGuess, _
            OrderCustom:=1, MatchCase:=False, Orientation:=xlTopToBottom, _
            DataOption1:=xlSortNormal
        'sort the data
Set rngContracts = .Range("D1:D" & .Cells(Rows.Count, "D").End(xlUp).Row)
        'the range containing data
        rngContracts.AdvancedFilter _
            Action:=xlFilterCopy, CopyToRange:=Range("J1"), Unique:=True
        'copy the unique entries to another range (amend "J1" to suit)
        Set rngUnique = .Range("J2:J" & .Cells(Rows.Count, "J").End(xlUp).Row)
        'the range of unique contract numbers (start from J2 to exclude header)
For Each rngCell In rngUnique
If rngCell.Value > 0 Then
strFName = strDir & rngCell.Value & ".xls"
                If FileExists(strFName) Then
                    Set wbkContract = Workbooks.Open(Filename:=strFName)
                Else
                    Set wbkContract = Workbooks.Add
                    wbkContract.SaveAs Filename:=strFName
                End If
                'check if workbook already exists, if not then create it
rngContracts.AutoFilter Field:=1, Criteria1:=rngCell.Value
                Set rngCopy = .AutoFilter.Range.Offset(1, -3).Resize _
                    (.AutoFilter.Range.Rows.Count - 1, 8).SpecialCells(xlCellTypeVisible)
                'AutoFilter contract data and resize
rngCopy.Copy Destination:=wbkContract.Worksheets("Sheet1").Range("A2")
                wbkContract.Close savechanges:=True
                'copy data and then close the contract workbook (saving changes)
rngContracts.AutoFilter
End If
Next rngCell
        'loop through each contract
End With
Application.ScreenUpdating = True
End Sub

Function FileExists(strFullname As String) As Boolean
    FileExists = Dir(strFullname) <> ""
End Function