Problem with Pearson Code

[Ramthebuffs]

I got this from the debruin site. It creates a new worksheet for each
different entry in a column or adds the the information if the
worksheet is already present. When you run it once it works fine, but
if you run it again it will not add the information to the already
present sheet. It will just create a new worksheet called sheet50, the
next is sheet51 etc.

I've run the code over the exact same sheet twice, so its not that
there is any differences in the data. The data I'm sorting by is
generally only 3 characters long. Could that be the problem?

On other slight problem I'm having with the same code is that row 1 is
copied to every sheet matching or not. I tried to shift 1:1 xlDown,
but apparently that doesn't work with advance filter.

Excel 2003

Sub Copy_With_AdvancedFilter_2()
' This sub use the functions LastRow and SheetExists
Dim CalcMode As Long
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim rng As Range
Dim rng2 As Range
Dim cell As Range
Dim Lrow As Long
Dim Lr As Long



Set ws1 = Sheets("Sheet1")
Set rng = ws1.Range("A1:N20000")
'Use a Dynamic range name,
http://www.contextures.com/xlNames01.html#Dynamic
'This example filter on the first column in the range (change this
if needed)



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



With ws1
rng.Columns(2).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=.Range("IV1"), Unique:=True
'You see that the last two columns of the worksheet are used to
make a Unique list
'and add the CriteriaRange.(you can't use this macro if you use
the columns)


Lrow = .Cells(Rows.Count, "IV").End(xlUp).Row
..Range("IU1").Value = .Range("IV1").Value



For Each cell In .Range("IV2:IV" & Lrow)
..Range("IU2").Value = cell.Value

If SheetExists(cell.Value) = False Then
Set ws2 = Sheets.Add
On Error Resume Next
ws2.Name = cell.Value
On Error GoTo 0
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=ws2.Range("A1"), _
Unique:=False

Else
Set ws2 = Sheets(cell.Text)
Lr = LastRow(ws2)
rng.AdvancedFilter Action:=xlFilterCopy, _
CriteriaRange:=.Range("IU1:IU2"), _
CopyToRange:=ws2.Range("A" & Lr +
1), _
Unique:=False
ws2.Range("A" & Lr + 1).EntireRow.Delete
End If

Next
..Columns("IU:IV").Clear
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

 

[Ron de Bruin]

Good morning

Do you have headers above your data (first row in the range)
This is the example
http://www.rondebruin.nl/copy5.htm#existing

 

[Ramthebuffs]

I dont have headers on the data. That is why I reference to A1. Should
I have headers?

 

[Ron de Bruin]

Yes