Need help to modify RDB code

[winnie123]

Hi,

I have found RDB code of SplitInWorksheets
which seems to do most of what I want. It copies rows from a list and splits
the data into different worksheets with the name of a selected value, in my
case its the Customer name.

The problem I have is that when the code runs again it adds a new worksheet
with an name error_00001 and so on.

I would like to mod the code so that if the worksheet already exist delete
the existing data and then copy.

I would appreciate any help as I just seem to be going round in circles and
still trying to learn .

code below is a part of the macro which I thinks need modifying

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

'Filter the range
My_Table.Range.AutoFilter Field:=FieldNum, Criteria1:="=" & _

Replace(Replace(Replace(cell.Value, "~", "~~"), "*", "~*"), "?", "~?")

CCount = 0
On Error Resume Next
CCount =
My_Table.ListColumns(1).Range.SpecialCells(xlCellTypeVisible).Areas(1).Cells.Count
On Error GoTo 0

If CCount = 0 Then
MsgBox "There are more than 8192 areas for the value : "
& cell.Value _
& vbNewLine & "It is not possible to copy the
visible data to a new worksheet." _
& vbNewLine & "Tip: Sort your data before you use
this macro.", _
vbOKOnly, "Split in worksheets"
Else
Set WSNew = Worksheets.Add(after:=Sheets(Sheets.Count))
On Error Resume Next
WSNew.Name = cell.Value
If Err.Number > 0 Then
ErrNum = ErrNum + 1
WSNew.Name = "Error_" & Format(ErrNum, "0000")
Err.Clear
End If
On Error GoTo 0

'Copy the visible data and use PasteSpecial to paste to
the new worksheet
My_Table.Range.SpecialCells(xlCellTypeVisible).Copy
With WSNew.Range("A1")
.PasteSpecial xlPasteColumnWidths
.PasteSpecial xlPasteValues
.PasteSpecial xlPasteFormats
Application.CutCopyMode = False
.Select
End With
End If


Thanks Winnie

 

[Ron de Bruin]

Hi Winnie


Use
http://www.rondebruin.nl/copy5_5.htm

And change this part

Else
Set WSNew = Sheets(cell.Text)
Lr = LastRow(WSNew)
Set DestRange = WSNew.Range("A" & Lr + 1)
End If

To

Else
Set WSNew = Sheets(cell.Text)
WSNew.Cells.Clear
Lr = 1
Set destrange = WSNew.Range("A" & Lr + 1)
End If

 

[winnie123]

Thanks for the reply.

I have followed your advice and copied the code, changed as suggested.
Put the functions above the code.

Also changed the code at the beginning so that it looked at a specific sheet

Set My_Range = Worksheets("PriceData").Range("C1:G" &
LastRow(Worksheets("PriceData")))
My_Range.Parent.Select

and chaged the column to filter on as 4 as i want to filter on Col F

But it ends up with the rows below the headers on the PriceData sheet being
hidden.
It also copies the name tabs correctly with header rows but no data below.
All the data has been copied to the sheet which is the first value in Col F,
ie F2

Have I done anything wrong, can you help again please

Thanks
Winnie

 

[Ron de Bruin]

Try it first in the workbook you can download from my site and see if it is working OK
http://www.rondebruin.nl/copy5.htm

After that try it on your own data

 

[winnie123]

Thanks Ron, I have got it to work.

Thanks very much, you make so much easier.

just a little note when you run the code the 2nd time all the worksheets
with the copied data on start on row 2

This happens on your workbook also.

Ta
Winnie

 

[Ron de Bruin]

Yes, I forgot to delete this

'Set destrange = WSNew.Range("A" & Lr + 1)

Remove the +1


--

Regards Ron de Bruin
http://www.rondebruin.nl/tips.htm

 

[winnie123]

Thanks once again,

working perfectly.

Thanks for your help.