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