Home Menu

Menu


ExcelBanter » Excel Newsgroups » Excel Programming > Macro Suddenly Stopped Working
Reply
 
LinkBack Thread Tools Search this Thread Display Modes
  #1   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 7
Default 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!

Reply With QuoteReply With Quote
  #2   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 38
Default 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!


Reply With QuoteReply With Quote
  #3   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 38
Default 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!


Reply With QuoteReply With Quote
  #4   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 7
Default 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

Reply With QuoteReply With Quote
  #5   Report Post  
Posted to microsoft.public.excel.programming
external usenet poster
  
Posts: 10,124
Default 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


Reply With QuoteReply With Quote
Reply
Thread Tools Search this Thread
Search this Thread:

Advanced Search
Display Modes
Linear Mode Linear Mode

Posting Rules
Smilies are On
[IMG] code is On
HTML code is Off
Trackbacks are On
Pingbacks are On
Refbacks are On

Similar Threads
Thread Thread Starter Forum Replies Last Post
Histogram function suddenly stopped working Allisonnl09 Excel Discussion (Misc queries) 2 December 17th 08 04:17 AM
Visual Basic suddenly stopped working amirstal Excel Programming 1 December 8th 06 04:14 AM
Help: Excel 4 macro suddenly no longer working Keske Saram Excel Programming 0 July 4th 05 02:15 AM
HELP!! Macro suddenly not working onedaywhen Excel Programming 0 February 9th 04 10:41 AM
HELP!! Macro suddenly not working rodt[_2_] Excel Programming 0 February 7th 04 06:28 AM


All times are GMT +1. The time now is 02:00 PM.

Powered by vBulletin® Copyright ©2000 - 2024, Jelsoft Enterprises Ltd.
Copyright ©2004-2024 ExcelBanter.
The comments are property of their posters.
 

About Us

"It's about Microsoft Excel"

 

Contact Us ExcelBanter forum home Privacy Statement