Conditional Copy/Paste

[mjack003]

This thread is out of control. I ran into a major major snag though
I added two lines to the bottom to do some formatting to each sheet an
now if the worksheet already exists it is only pasting column A.
However if it creates a new sheet it pastes A:G. Now its completel
locking up and telling me "Copy method of worksheet class failed" an
isn't doing a thing! Here is the code:

Option Explicit
Sub FilterBoxes()
Dim c As Range
Dim ws As Worksheet
Dim boxListRange As Range
Dim dummyRng As Range
Dim myDataBase As Range

With Worksheets("Teardown Inventory")
Set dummyRng = .UsedRange 'try to reset lastusedcell
Set myDataBase = .Range("a5", .Cells.SpecialCells(xlCellTypeLastCell))
End With
myDataBase.Name = "Database"

'rebuild the CityList
Worksheets("Boxes").Columns(1).Clear
With Sheets("Teardown Inventory")
.Range("g5:g" & _
.Cells(.Rows.Count, "g").End(xlUp).Row).AdvancedFilter _
Action:=xlFilterCopy, _
CopyToRange:=Sheets("Boxes").Range("A1"), _
Unique:=True
End With

With Sheets("Boxes")
Set boxListRange = .Range("a1", .Cells(.Rows.Count, "A").End(xlUp))
With boxListRange
.Sort Key1:=.Cells(1), Order1:=xlAscending, _
Header:=xlYes, OrderCustom:=1, _
MatchCase:=False, Orientation:=xlTopToBottom
.Resize(.Rows.Count - 1, 1).Offset(1, 0).Name = "BoxList"
End With
End With

Sheets("Boxes").Range("D1").Value = _
Sheets("Teardown Inventory").Range("g5").Value

'check for individual City worksheets
For Each c In Range("BoxList")
If c.Value = "" Then
'do nothing
Else
If WksExists(CStr(c.Value)) = False Then
Worksheets("Header").Copy after:=Sheets(Sheets.Count)
ActiveSheet.Name = c.Value
Else
Worksheets(CStr(c.Value)).Rows("17:65536").Clear
End If

'change the criteria in the Criteria range
'Sheets("Boxes").Range("D2").Value = c.Value Changed to String below
Sheets("boxes").Range("D2").Value = "=" & Chr(34) & "=" & c.Value
Chr(34)

'transfer data to individual City worksheets
Sheets("Teardown Inventory").Range("Database").AdvancedFilter _
Action:=xlFilterCopy, _
CriteriaRange:=Sheets("Boxes").Range("D12"), _
CopyToRange:=Sheets(CStr(c.Value)).Range("A16"), _
Unique:=False

--->Sheets(CStr(c.Value)).Range("E13").Value = c.Value

--->Sheets(CStr(c.Value)).Range("F16").Value = "Shipping Date"


End If
Next
MsgBox "Data has been sent"
End Sub

Function WksExists(wksName As String) As Boolean
On Error Resume Next
WksExists = CBool(Len(Worksheets(wksName).Name) > 0)
End Function


Best Regards,
Mjac

 

[Dave Peterson]

These are difficult to find.

But you're clearing this range:
Worksheets(CStr(c.Value)).Rows("17:65536").Clear

but you're pasting into:
CopyToRange:=Sheets(CStr(c.Value)).Range("A16")

So I'm guessing that there's some junk left in row 16 that's interferring with
the advanced filter. (at least in my testing with headers through row 17, it
screwed up for me.)

but when I cleared 16:65536 (or pasted in A17), it seemed to work ok.

Drop it down a couple of rows beyond you're header and you'll see what's causing
the trouble.