Macro Suddenly Stopped Working

H

hvfr902

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!
 
R

Rich J

I'm not an expert but is the sheet you are doing this on protected ? If the
macro tries to paste to a locked cell you will get a runtime error.
 
R

Rich J

Was a protected worksheet the problem ?

[email protected] said:
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!
Click to expand...
 
D

Don Guillett

it's hard to tell with all of the other calls not available to see. The code
appears to be overly complex and simple at the same time with un-necessary
selections. What do you mean when you say "stopped working"? Was there
something in the source to copy??
Range("B1:B" & lLastCellInRange).Select 'empty??
Selection.Copy
should have removed selections, here and elsewhere, but that won't cure your
problem.
Range("B1:B" & lLastCellInRange).Copy
 

Ask a Question

Want to reply to this thread or ask your own question?

You'll need to choose a username for the site, which only take a couple of moments. After that, you can post your question and our members will help you out.

Ask a Question

Similar Threads

VBA Coding Help for Beginner 0
Excel crashes and restarts when accessing newly created worksheet 2
Word macro that can call cells out of Excel for a find and replace 0
Macro to Select text from a point given to a specific word 2
error trying to sort data 4
Add to existing macro 3
MACRO Effeciency 3
Development combinations with exclusion of columns 0

Top