Runs once and only once

[ryguy7272]

The code below, slightly modified, is from Ron de Bruin's site. It seems to
work fine the first time, but that's it. I start with only one sheet
(contains all summary data)and then urn it -- everything is fine. On
subsequent runs, with all sheets deleted except for the summary sheet, it
fails, usually here:
On Error Resume Next

Or here:
Err.Clear

Or here:
Application.CutCopyMode = False

It must be some kind of memory issue, but I can't figure out what, exactly.
Can someone think of a resolution.


Sub Copy_To_Worksheets_2()
' This sub uses the functions LastRow and SheetExists
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim WSNew As Worksheet
Dim rng As Range
Dim cell As Range
Dim Lrow As Long
Dim DestRange As Range
Dim FieldNum As Integer
Dim Lr As Long
Dim KeyCol As Integer
'Dim sh As Worksheet


KeyCol = InputBox("What column #? Choose 6, or 11, or 16")

'Name of the sheet with your data
Set ws1 = Sheets("Sheet1") '<<< Change

'Set filter range : A1 is the top left cell of your filter range and
'the header of the first column, D is the last column in the filter range
Set rng = ws1.Range("A1:X" & Rows.Count)

'Set Field number of the filter column
'This example filters on the first field in the range(change the field
if needed)
'In this case the range starts in A so Field:=1 is column A, 2 = column
B, ......
FieldNum = KeyCol

With Application
CalcMode = .Calculation
.Calculation = xlCalculationManual
.ScreenUpdating = False
End With

' Add a worksheet to copy the a unique list and add the CriteriaRange
Set ws2 = Worksheets.Add

With ws2
'first we copy the Unique data from the filter field to ws2
rng.Columns(FieldNum).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("A1"), Unique:=True

'loop through the unique list in ws2 and filter/copy to a worksheet
Lrow = .Cells(Rows.Count, "A").End(xlUp).Row
For Each cell In .Range("A2:A" & Lrow)

If SheetExists(cell.Value) = False Then
Set WSNew = Sheets.Add
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number > 0 Then
MsgBox "Change the name of : " & WSNew.Name & " manually"
Err.Clear
End If
On Error GoTo 0
Set DestRange = WSNew.Range("A1")
Else
Set WSNew = Sheets(cell.Text)
Lr = LastRow(WSNew)
Set DestRange = WSNew.Range("A" & Lr + 1)
End If

'Firstly, remove the AutoFilter
ws1.AutoFilterMode = False

'Filter the range
rng.AutoFilter Field:=FieldNum, Criteria1:="=" & cell.Value

'Copy the visible data and use PasteSpecial to paste to the
worksheet
ws1.AutoFilter.Range.Copy
With DestRange
'.Parent.Select
' Paste:=8 will copy the columnwidth in Excel 2000 and higher
'.PasteSpecial Paste:=8
.PasteSpecial xlPasteValues
'.PasteSpecial xlPasteFormats
'Application.CutCopyMode = False
'.Select
End With
' Delete the header row if you copy to a existing worksheet
If Lr > 0 Then WSNew.Range("A" & Lr + 1).EntireRow.Delete

'Close AutoFilter
ws1.AutoFilterMode = False

Lr = 0
Next cell

'Delete the ws2 sheet
On Error Resume Next
Application.DisplayAlerts = False
.Delete
Application.DisplayAlerts = True
On Error GoTo 0

End With

With Application
.ScreenUpdating = True
.Calculation = CalcMode
End With
End Sub

Function LastRow(sh As Worksheet)
On Error Resume Next
LastRow = sh.Cells.Find(What:="*", _
After:=sh.Range("A1"), _
Lookat:=xlPart, _
LookIn:=xlValues, _
SearchOrder:=xlByRows, _
SearchDirection:=xlPrevious, _
MatchCase:=False).Row
On Error GoTo 0
End Function


Function SheetExists(SName As String, _
Optional ByVal WB As Workbook) As Boolean
'Chip Pearson
On Error Resume Next
If WB Is Nothing Then Set WB = ThisWorkbook
SheetExists = CBool(Len(WB.Sheets(SName).Name))
End Function

Regards,
Ryan---

 

[ryguy7272]

I believe it is some kind of memory allocation issue. I'll deal with it, or
just learn to live with it (closing Excel and reopening it seems to work
reasonably well).
Thanks to all who looked.
Ryan--