Copy row from one sheet to one of many others

[Homer]

I have a code from Ron de Bruin's website that I used to copy rows from a
data sheet to multiple other sheets based on the contents of a cell in column
AG.

The code worked great in setting up the sheets. The problem I get is when I
add a row to the data sheet and run the code I get an error message,
"Subscript out of range".

The data sheet has 33 colums ending in AG. I do not have any merged cells,
there are no empty rows and the headers are unique.

I need to be able to add a row to the data sheet and have it copied to the
corresponding sheet.

Here is a copy of the code I am using:
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

'Name of the sheet with your data
Set ws1 = Sheets("All") '<<< 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:ag" & 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 = 33

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

 

[Dave Peterson]

Which line causes the error?

The "Subscript out of range" can mean something as simple as a worksheet that
doesn't exist:

worksheets("doesnotexist").range("a1").value = 5

 

[Homer]

Dave,

Thank you for your help. I realized the problem was something that I was
missing in the way the sheet is set up so I re-created the sheet from scratch
and it works, almost.

When I run the code it adds all rows again so I end up with duplicate rows.
I figure if I can have it delete the rows already in place, like it does the
header row, the sheets will be updated correctly.

Here is a section of the code that I believe I need to do this in, but can't
figure out how:

' Delete the header row if you copy to a existing worksheet
If Lr > 0 Then WSNew.Range("A" & Lr + 1).EntireRow.Delete

Thanks again,

Don

 

[Dave Peterson]

I would delete the worksheet and start from scratch each time.

This portion:

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

changes to:

For Each cell In .Range("A2:A" & Lrow)

on error resume next
worksheets(Cell.value).delete
on error goto 0

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

=======
The line you suggested to delete points at the copied|Pasted header from the
autofilter range. Nothing to do with duplicated rows.

 

[Homer]

Dave,

Your change works great. Thank you for your assistance.

I had an issue in how it was handling a blank cell in column AG. But I
figured out that I shouldn't have a blank cell.

Thanks,
Don

 

[Dave Peterson]

One way around it is to look at each cell in the range:

For Each cell In .Range("A2:A" & Lrow)
if trim(cell.value) = "" then
'skip it
else
'do all the work
end if

Another way may be to sort the results of the advanced filter. If the cell is
really empty, it'll sort to the bottom and it won't be included in:

For Each cell In .Range("A2:A" & Lrow)

But if the cell looks empty (maybe the result of a formula like =""), then this
technique wouldn't work.

Dave,

Your change works great. Thank you for your assistance.

I had an issue in how it was handling a blank cell in column AG. But I
figured out that I shouldn't have a blank cell.

Thanks,
Don

 

[Homer]

Dave,

Without your help I would not have been able to make this work. The time,
and high blood pressure, I will save is enormous.

Thank you very much.

Don