Over-Eager code is pasting 3 times

[Stuart]

The code is running on the activeworkbook, where data is in
rows A:G. An identifier for the provisional start of each
record is in col A (defined as "A" & Cell.Row). User can
identify records to be copied using A, B , C etc in cols I to J
in Cell.Row
So, having found a record ("A" & Cell.Row) I now check to
see if the range(("H" & Cell.Row, "J" & Cell.Row) contains
any user tags, and if so, then copy the record to the destination
Workbooks("Sorted_Tagged " & x(4) & ".xls"). _
Worksheets(TagCell.Value) for each tag, present.

Here's current code:

For Each TagCell In .Range("H" & Cell.Row, "J" & Cell.Row) _
.SpecialCells(xlConstants)
If Not IsEmpty(TagCell) Then
.Range("A" & StartCopyRow, "J" & EndCopyRow).Copy _
Destination:=Workbooks("Sorted_Tagged " _
& x(4) & ".xls").Worksheets(TagCell.Value) _
.Range("B65536").End(xlUp).Offset(2, -1)
If Not IsEmpty(.Range("F" & StartCopyRow).End(xlDown) _
.Offset(-1, -5)) Then
.Range("F" & StartCopyRow).End(xlDown) _
.Offset(-1, -5).Copy _
Destination:=Workbooks _
("Sorted_Tagged " & x(4) & ".xls"). _
Worksheets(TagCell.Value) _
.Range("A65536").End(xlUp).Offset(0, 10)
End If
End If
Next

All is fine except that if user has tagged all 3 cols against a
record, then I'm getting 3 copies of the record pasting into each
of the 3 destination sheets(g).

Would be very grateful for help in explaining this, please.


Regards.

 

[Dick Kusleika]

Stuart

You're looping through the three cells in H:J and they must all have
something in them because your code is executing three times. You might
consider something like

If Application.CountA(Range("H" & Cell.Row, etc..)) > 0 Then
'do copying
End If

 

[Stuart]

Thanks for the suggestion.
If it's of interest, I ended up with a (so far) working solution,
as follows:

LastRow = .Range("F65536").End(xlUp).Offset(-1, -4).End(xlUp).Row
If LastRow > 1 Then
If Application.CountA(.Range("H2", "H" & LastRow)) > 0 Then
For Each Cell In .Range("H2", "H" & LastRow).SpecialCells(xlConstants)
If Not IsEmpty(Cell) Then
StartCopyRow = .Range("A" & Cell.Row).End(xlUp).Offset(0, 1) _
.End(xlDown).Row
EndCopyRow = Cell.Row
'For Chris Webber's type of BofQ use:
'EndCopyRow = .Range("B" & Cell.Row).End(xlDown).Offset(-1, 0).Row
'For normal BofQ's use
'EndCopyRow = Cell.Row
Application.CutCopyMode = False
.Range("A" & StartCopyRow, "J" & EndCopyRow).Copy
Workbooks("Sorted_Tagged " & x(4) & ".xls") _
.Worksheets(.Range("H" & Cell.Row).Value) _
.Range("B65536").End(xlUp).Offset(2, -1) _
.PasteSpecial
If Not IsEmpty(.Range("F" & StartCopyRow).End(xlDown) _
.Offset(-1, -5)) Then
.Range("F" & StartCopyRow).End(xlDown) _
.Offset(-1, -5).Copy 'take the page no.
Workbooks("Sorted_Tagged " & x(4) & ".xls"). _
Worksheets(.Range("H" & Cell.Row).Value).Range _
("A65536").End(xlUp).Offset(0, 10).PasteSpecial
End If
End If
If Not IsEmpty(Cell.Offset(0, 1)) Then 'col I
StartCopyRow = .Range("A" & Cell.Row).End(xlUp).Offset(0, 1) _
.End(xlDown).Row
EndCopyRow = Cell.Row
.Range("A" & StartCopyRow, "J" & EndCopyRow).Copy
Workbooks("Sorted_Tagged " & x(4) & ".xls") _
.Worksheets(.Range("I" & Cell.Row).Value) _
.Range("B65536").End(xlUp).Offset(2, -1) _
.PasteSpecial
If Not IsEmpty(.Range("F" & StartCopyRow).End(xlDown) _
.Offset(-1, -5)) Then
.Range("F" & StartCopyRow).End(xlDown) _
.Offset(-1, -5).Copy
Workbooks("Sorted_Tagged " & x(4) & ".xls"). _
Worksheets(.Range("I" & Cell.Row).Value).Range _
("A65536").End(xlUp).Offset(0, 10).PasteSpecial
End If
End If
If Not IsEmpty(Cell.Offset(0, 2)) Then 'col J
StartCopyRow = .Range("A" & Cell.Row).End(xlUp).Offset(0, 1) _
.End(xlDown).Row
EndCopyRow = Cell.Row
.Range("A" & StartCopyRow, "J" & EndCopyRow).Copy
Workbooks("Sorted_Tagged " & x(4) & ".xls") _
.Worksheets(.Range("J" & Cell.Row).Value) _
.Range("B65536").End(xlUp).Offset(2, -1) _
.PasteSpecial
If Not IsEmpty(.Range("F" & StartCopyRow).End(xlDown) _
.Offset(-1, -5)) Then
.Range("F" & StartCopyRow).End(xlDown) _
.Offset(-1, -5).Copy
Workbooks("Sorted_Tagged " & x(4) & ".xls"). _
Worksheets(.Range("J" & Cell.Row).Value).Range _
("A65536").End(xlUp).Offset(0, 10).PasteSpecial
End If
End If
Next
End If
End If

A little inelegant, but it seems to work. Undoubtedly slower also.

Regards and thanks.

 

[Stuart]

Point taken, since the formatting of the target workbook
has already been done!

Regards.