Macro Suddenly Stopped Working
Was a protected worksheet the problem ?
" wrote:
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!
|