Hi,

The macro suddenly stopped working and the user that created it is no
longer with us. the macro is below - any help would be great!

It is stopping at Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks:=False, Transpose:=True

and giving an run time error 1004

Sub NormalizeData()
Dim rngToSearch As Range
Dim Cell As Range
Dim rngPaste As Range
Dim lLastCellInRange As Long
Dim shScratch As Worksheet
Dim shCriterion As Worksheet
Dim shDupeData As Worksheet
Dim shRawData As Worksheet
Dim strCurSheet As String

strCurSheet = ActiveSheet.Name

Call UnhideWorksheet("criterion")
Call UnhideWorksheet("scratch")

Set shScratch = Worksheets("scratch")
Set shCriterion = Worksheets("criterion")
Set shRawData = Worksheets("ShoePolishRawData")
Set shDupeData = Worksheets("DupeData")

shDupeData.Select

Call GetUniques

Set rngToSearch = shDupeData.Range("C:C")
Set rngPaste = shDupeData.Range("D1")

lLastCellInRange = shRawData.UsedRange.Rows.Count

If Not rngToSearch Is Nothing Then
For Each Cell In rngToSearch
If Cell.value < "acctno" Then
If Not IsEmpty(Cell.value) Then
'Delete everything in scratch sheet
shScratch.Select
Cells.Select
Selection.Delete Shift:=xlUp

'Paste the criteria
shCriterion.Select
Range("A2").value = Cell.value

'Get the data
shRawData.Columns("A:B").AdvancedFilter
Action:= _
xlFilterCopy,
CriteriaRange:=Range("criterion!$A$1:$A$2"),
CopyToRange:=Range("scratch!A1"), Unique:=True

shScratch.Select
Rows("1:1").Select
Selection.Delete Shift:=xlUp
Range("B1:B" & lLastCellInRange).Select
Selection.Copy

shDupeData.Select

Set rngPaste = rngPaste.Offset(1, 0)
rngPaste.Select
Selection.PasteSpecial Paste:=xlPasteValues,
Operation:=xlNone, SkipBlanks:=False, Transpose:=True

Else
With shDupeData
.Range("A1").value = "Unique Tickets"
.Range("A1").Select
Selection.Font.Bold = True
.Range("A2").Select
.Range("A2").Formula = "=counta(D2:IV2)"
Selection.AutoFill
Destination:=Range("A2:A" & Cell.Row - 1), Type:=xlFillDefault

.Range("B1").value = "Purchases"
.Range("B1").Select
Selection.Font.Bold = True
.Range("B2").Select
.Range("B2").FormulaArray =
"=SUM(IF(ShoePolishRawData!$A$2:$A$" & lLastCellInRange &
"=C2,ShoePolishRawData!$G$2:$G$" & lLastCellInRange & ",0))"
Selection.AutoFill
Destination:=Range("B2:B" & Cell.Row - 1), Type:=xlFillDefault
End With

Call HideWorksheet("criterion")
Call HideWorksheet("scratch")

Worksheets(strCurSheet).Select

Exit Sub
End If
End If
Next
End If
End Sub

Private Sub GetUniques()
Dim sh As Worksheet

Set sh = Worksheets("DupeData")
sh.Cells.Select
Selection.Delete Shift:=xlUp

Worksheets("ShoePolishRawData").Range("A:A") _
.AdvancedFilter Action:=xlFilterCopy, _
CopyToRange:=sh.Range("C1"), _
Unique:=True

sh.Columns(3).Sort Key1:=sh.Range("C1"), _
Header:=xlYes

End Sub

Public Function CellFunction(Sheet As String, Cell As String)
Application.Volatile True
CellFunction = Worksheets(Sheet).Evaluate(Cell)
End Function

Public Function HideWorksheet(strSheetName)
Worksheets(strSheetName).Visible = False
End Function

Public Function UnhideWorksheet(strSheetName)
Worksheets(strSheetName).Visible = True
End Function


Thanks!