ExcelBanter - Macro Suddenly Stopped Working

ExcelBanter (https://www.excelbanter.com/)

- Excel Programming (https://www.excelbanter.com/excel-programming/)

- - Macro Suddenly Stopped Working (https://www.excelbanter.com/excel-programming/387340-macro-suddenly-stopped-working.html)

[email protected]

Macro Suddenly Stopped Working

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!

Rich J[_2_]

Macro Suddenly Stopped Working

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.

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

Rich J[_2_]

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!

[email protected]

Macro Suddenly Stopped Working

On Apr 13, 3:42 pm, Rich J wrote:
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!- Hide quoted text -

- Show quoted text -

None of the sheets are protected - and the issue still exists

Don Guillett

Macro Suddenly Stopped Working

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

--
Don Guillett
SalesAid Software

wrote in message
oups.com...
On Apr 13, 3:42 pm, Rich J wrote:
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!- Hide quoted text -

- Show quoted text -

None of the sheets are protected - and the issue still exists

All times are GMT +1. The time now is 02:22 AM.