On Saturday, October 6, 2012 3:12:22 AM UTC-5, Howard wrote:
Excel 2010



When I run this code it takes a tiny bit less than one second for each entry with no "X" in the column to the left and at least a full second if it has to cut & paste the resized cells in response to the "X" in the column to the left.



The worksheet also seems to be slower than normal using common sheet procedures like selecting a couple of cells and draging them to another column, same slowness with cut and paste of 150 to 250 entries in a column to another column.



The sheets data is about 50 columns by 300 rows and a "storage column" just over 1000 rows. Doesn't seem like much data after some examples I have heard about in these news groups.



I'm going on poor memory here now, but I seem to recall some reason for slowness may be a HUGE used range on the sheet. Cure was something like selectin all the empty rows beyond what you need and do something with them and then do the same with the columns. Save and restate Excel might be part of the cure also. I have used Ctrl + down arrow several times and gone to the million'th plus row (bottom of the column). Maybe thats it???



Any ideas?



Option Explicit

Sub CopyLeft()

'activecell must start row 1 to row 16 of column



Dim c As Range

Dim j As Integer

ActiveCell.End(xlDown).Select



j = ActiveCell.End(xlDown).Row

ActiveCell.Resize(j - 16, 1).Select



With Selection

For Each c In Selection

If c.Offset(0, -1).Value = "X" Then

c.Resize(1, 2).Cut c.Offset(0, -2)

End If

Next

End With



End Sub



Thanks.

Regards,

Howard
Assuming the CF has been applied and OP selects row17 of the source cell with the shaded cells, this will do as desired.
Option Explicit

Sub SeparateDuplicatesFromNonDuplicates()
Dim mc As Long
Dim lr As Long
'========
mc = ActiveCell.Column


Application.ScreenUpdating = False
If mc = 0 Or ActiveCell.Row < 17 Then Exit Sub
Cells(17, "ae").Resize(1000, 2).Clear

lr = Cells(Rows.Count, mc).End(xlUp).Row
Range(Cells(17, mc), Cells(lr, mc + 1)).Copy Range("ag17")
With Range("$AG$16:$AH$" & lr)
.AutoFilter Field:=1, Criteria1:=RGB(255 _
, 199, 206), Operator:=xlFilterCellColor
.Offset(1).SpecialCells(xlCellTypeVisible).Copy Range("ae17")
.Offset(1).SpecialCells(xlCellTypeVisible).Clear
.AutoFilter
.SpecialCells(xlCellTypeBlanks).Delete shift:=xlUp
End With
Application.ScreenUpdating = True
Range("ae17").Select
Range("ag13") = "You selected cell " & Cells(17, mc).Address
End Sub