On Sunday, October 7, 2012 9:57:28 AM UTC-7, joeu2004 wrote:
"Howard" wrote:

My data does indeed start in row 17 and I just needed a

down and dirty way to separate the dupes into a seperate

column and then I can minupliate the two columns data as

I want.



How about a clean way? ;-)



First, if your are using Conditional Formatting only for this purpose, and

if the following suggestions work for you, it is important that you

eliminate the CFs.



In other forums, others have claimed that (some) CFs are "volatile"

formulas. So for each cut-and-paste that you might do, __all__ of the CFs

are re-evaluated. And that might sense given your application.



That could explain why your algorithm takes so much longer for you (18 to 30

sec, you said) than for me (3.4 sec, but increasing each time sometimes).



Second, the following macro might do what you require. It assumes that you

format the columns separately. It also assumes that you select at least the

upper-left cell of the 2-column data.



The following macro behaves similar to yours: it simply moves duplicates to

the left. That leaves gaps in the original data.



On my computer (YMMV), the run time is less than 0.08 seconds for 1500 data

with 1499 duplicates (worst case), compared to 3.4 seconds or more for your

cut-and-paste algorithm.



Caveat: I am guessing at the condition that identifies a duplicate, namely

that the values in __both__ columns are the same; that is:



If orig(j, 1) = orig(i, 1) And orig(j, 2) = orig(i, 2) Then



Remove either ``And orig(j, 2) = orig(i, 2)`` or ``orig(j, 1) = orig(i, 1)

And`` if only one comparison is needed.





' assume upper-left cell of data is selected

' and data are 2 rows or more

Sub moveDupe()

Dim st As Double

Dim origRng As Range

Dim orig As Variant

Dim n As Long, i As Long, j As Long

st = Timer

With Application

.ScreenUpdating = False

.Calculation = xlCalculationManual

End With

Set origRng = Range(ActiveCell, ActiveCell.End(xlDown)).Resize(, 2)

orig = origRng

n = UBound(orig, 1)

ReDim dupe(1 To n, 1 To 2) As Variant

For i = 1 To n - 1

If orig(i, 1) < "" And orig(i, 2) < "" Then

For j = i + 1 To n

If orig(j, 1) = orig(i, 1) And orig(j, 2) = orig(i, 2) Then

dupe(j, 1) = orig(j, 1)

dupe(j, 2) = orig(j, 2)

orig(j, 1) = ""

orig(j, 2) = ""

End If

Next

End If

Next

origRng = orig

origRng.Offset(0, -2) = dupe

With Application

.Calculation = xlCalculationAutomatic

.ScreenUpdating = True

End With

MsgBox Format(Timer - st, "0.000") & " sec"

End Sub





The following macro builds two lists so that are no gaps in either one. The

run time is about the same, under 0.08 seconds on my computer.





' assume upper-left cell of data is selected

' and data are 2 rows or more

Sub moveDupejoeuNG()

Dim st As Double

Dim origRng As Range

Dim orig As Variant

Dim n As Long, i As Long, j As Long

Dim un As Long, dn As Long

st = Timer

With Application

.ScreenUpdating = False

.Calculation = xlCalculationManual

End With

Set origRng = Range(ActiveCell, ActiveCell.End(xlDown)).Resize(, 2)

orig = origRng

n = UBound(orig, 1)

ReDim uniq(1 To n, 1 To 2) As Variant

ReDim dupe(1 To n, 1 To 2) As Variant

un = 0: dn = 0

For i = 1 To n - 1

If orig(i, 1) < "" And orig(i, 2) < "" Then

For j = i + 1 To n

If orig(j, 1) = orig(i, 1) And orig(j, 2) = orig(i, 2) Then

dn = dn + 1

dupe(dn, 1) = orig(j, 1)

dupe(dn, 2) = orig(j, 2)

orig(j, 1) = ""

orig(j, 2) = ""

End If

Next

un = un + 1

uniq(un, 1) = orig(i, 1)

uniq(un, 2) = orig(i, 2)

End If

Next

origRng = uniq

origRng.Offset(0, -2) = dupe

With Application

.Calculation = xlCalculationAutomatic

.ScreenUpdating = True

End With

MsgBox Format(Timer - st, "0.000") & " sec"

End Sub

Hi Joeu,
This is the code you offered that does the "No Gaps" and as far as I can tell in my short experimenting with it is heading in the right direction! The only problem is that the condition that identifies a duplicate in in the XO column only. Is that fixable, to identify the dupes within the XO colomn and move the data with no gaps??? If so then I believe we have a winner.

I renamed it so I can keep track of who authored it and the NG is for No Gaps.

(From your message above)
Caveat: I am guessing at the condition that identifies a duplicate, namely
that the values in __both__ columns are the same; that is:

If orig(j, 1) = orig(i, 1) And orig(j, 2) = orig(i, 2) Then
Remove either ``And orig(j, 2) = orig(i, 2)`` or ``orig(j, 1) = orig(i, 1)

And`` if only one comparison is needed.





Sub moveDupejoeuNGap()

Dim st As Double
Dim origRng As Range
Dim orig As Variant
Dim n As Long, i As Long, j As Long
Dim un As Long, dn As Long

st = Timer
With Application
.ScreenUpdating = False
.Calculation = xlCalculationManual
End With

Set origRng = Range(ActiveCell, ActiveCell.End(xlDown)).Resize(, 2)
orig = origRng
n = UBound(orig, 1)
ReDim uniq(1 To n, 1 To 2) As Variant
ReDim dupe(1 To n, 1 To 2) As Variant
un = 0: dn = 0
For i = 1 To n - 1
If orig(i, 1) < "" And orig(i, 2) < "" Then
For j = i + 1 To n
If orig(j, 1) = orig(i, 1) And orig(j, 2) = orig(i, 2) Then
dn = dn + 1
dupe(dn, 1) = orig(j, 1)
dupe(dn, 2) = orig(j, 2)
orig(j, 1) = ""
orig(j, 2) = ""
End If
Next
un = un + 1
uniq(un, 1) = orig(i, 1)
uniq(un, 2) = orig(i, 2)
End If
Next
origRng = uniq
origRng.Offset(0, -2) = dupe
With Application
.Calculation = xlCalculationAutomatic
.ScreenUpdating = True
End With
End Sub