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.
Can you check if you've enabled macro (ie, the macro security should not be high)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




Reply With Quote
Bookmarks