I checked the code (in 2007), and it doesn't seem to have any code that may not work in 2003. Anyway, I've made a minor modification in the code.
Code:
Option ExplicitOption Base 1
Sub ContractListt()
Dim AllCells As Range
Dim cell As Range, Rng As Range
Dim NoDupes As New Collection
Dim lrow As Long, Rlrow As Long
Dim Myval As Integer
Dim wks As Worksheet
Dim Item As Variant
Dim Hdrarray As Variant
Dim cnt As Long
Dim Ctempws As Worksheet
Application.ScreenUpdating = False
Set Ctempws = Sheets("Template")
lrow = Sheets("BD").Range("E" & Rows.Count).End(xlUp).Row
Set AllCells = Range("E42:E" & lrow)
For Each cell In AllCells
On Error Resume Next
NoDupes.Add cell.Value, CStr(cell.Value)
Next cell
On Error GoTo 0
For Each Item In NoDupes
Range("D41:BB41").Select
Selection.AutoFilter
With Selection
.AutoFilter Field:=2, Criteria1:=Item
End With
Set Rng = ActiveSheet.AutoFilter.Range
Myval = Range("D42:D" & lrow).SpecialCells(xlCellTypeVisible).Count
On Error Resume Next
Rlrow = Sheets(Item).Range("D" & Rows.Count).End(xlUp).Row + 1
If Err = 9 Then
Ctempws.Copy after:=Worksheets(Worksheets.Count)
ActiveSheet.Name = Item
With Sheets(Item)
Rlrow = .Range("D" & Rows.Count).End(xlUp).Row + 1
Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1).Copy
.Cells(Rlrow, 4).PasteSpecial xlValue
Application.CutCopyMode = xlCopy
Sheets(Item).Cells.EntireColumn.AutoFit
Sheets(Item).Range("D41").Select
Sheets("BD").Activate
End With
Else
Rng.Offset(1, 0).Resize(Rng.Rows.Count - 1).Copy
Sheets(Item).Cells(Rlrow, 4).PasteSpecial xlValue
Sheets(Item).Cells.EntireColumn.AutoFit
Sheets(Item).Range("D42").Select
Application.CutCopyMode = xlCopy
End If
Next Item
Selection.AutoFilter
End Sub
Can you check if you've enabled macro (ie, the macro security should not be high)
Bookmarks