Moving Duplicate cells

[DaveUK]

I have a long list of data in Column A of worksheet "Sheet1". I need to cut all duplicates into the C Column in the same row position.

I am using this code:

Sub insertRows()
ActiveSheet.Range("A1").Select
Do Until IsEmpty(ActiveCell)
Set curCell = ActiveCell
Set nextCell = ActiveCell.Offset(1, 0)
If nextCell.Value <> curCell.Value Then

??????????????????????

Else

??????????????????????

End If
Loop
End Sub

It cycles through column A and if it finds duplicate entries i then want to move both cell contents offset to the C column. And then continue to the end of all the data in the A column and do the same should their be duplicate cells next to each other.

Please could someone suggest the code to do this as i have tried resize and allsorts but nothing seems to work !!!!

Hope this makes sense!!

[anilsolipuram]

type in sample excel sheet value before and after executing macro

[DaveUK]

Thanks for the reply but i'm not sure what you mean !!!

Have tried similar to:


Sub insertRows()
ActiveSheet.Range("A1").Select
Do Until IsEmpty(ActiveCell)
Set curCell = ActiveCell
Set nextCell = ActiveCell.Offset(1, 0)
If nextCell.Value <> curCell.Value Then

'??????????????????????

Else

Range(curcell,nextcell).select
'??????????????????????

End If
Loop
End Sub




but not sure how to paste it to offeset column C.
Also not sure if this will work anyway.

[anilsolipuram]

Firstly, you have to sort the column A

I am not sure if this is what I am looking for.


Sub insertRows()
Dim st, en, g, k As Variant
g = 0
k = 1
Dim curcell, nextcell As Range
ActiveSheet.Range("A1").Select
Do Until IsEmpty(ActiveCell)
Set curcell = ActiveCell
Set nextcell = ActiveCell.Offset(1, 0)
ActiveCell.Offset(1, 0).Select
If nextcell.Value <> curcell.Value Then
If g = 1 Then
en = ActiveCell.Row - 1
Range("a" & (st + 1) & ":a" & en).Select
Selection.Copy

Range("c" & st).Select
Selection.PasteSpecial Paste:=xlAll, Operation:=xlNone, SkipBlanks:=False _
, Transpose:=True
Range("a" & st + 1 & ":a" & en).Select
Selection.Delete Shift:=xlUp
nextcell.Offset(1, 0).Select

en = ActiveCell.Row - 1
k = 1
ActiveCell.Offset(-(en - (st + 1)), 0).Select
End If
g = 0
Else
If g = 0 Then
st = ActiveCell.Row - 1
End If
k = k + 1
g = 1

End If
Loop
End Sub

[DaveUK]

Thanks for the reply.

This is what i get as the output.

1
2
3
12 12
32
45
54
63
436
454
632 632
3221


This is what i require.

1
2
3
12
12
32
45
54
63
436
454
632
632
32221

As can be seen (but i forgot to mention) i want both values moving to column C and the original cells emptying.

Any help appreciated.

[DaveUK]

Sorry not sure what went wrong there !!!!

Here it is again.


Thanks for the reply.

This is what i get as the output.

1
2
3
12 12
32
45
54
63
436
454
632 632
3221


This is what i require.

1
2
3
12
12
32
45
54
63
436
454
632
632
32221

As can be seen (but i forgot to mention) i want both values moving to column C and the original cells emptying.

Any help appreciated.

[anilsolipuram]

Try this and let me know

Sub insertRows()
Dim st, en, g, k As Variant
g = 0
k = 1
Dim curcell, nextcell As Range
ActiveSheet.Range("A1").Select
Do Until IsEmpty(ActiveCell)
Set curcell = ActiveCell
Set nextcell = ActiveCell.Offset(1, 0)
ActiveCell.Offset(1, 0).Select
If nextcell.Value <> curcell.Value Then
If g = 1 Then
en = ActiveCell.Row - 1
Range("a" & (st) & ":a" & en).Select
Selection.Copy

Range("c" & st).Select
ActiveSheet.Paste
Range("a" & st & ":a" & en).Select
Selection.Delete Shift:=xlUp
nextcell.Offset(1, 0).Select

en = ActiveCell.Row - 1
k = 1
ActiveCell.Offset(-(en - (st + 1)), 0).Select
End If
g = 0
Else
If g = 0 Then
st = ActiveCell.Row - 1
End If
k = k + 1
g = 1

End If
Loop
End Sub

[anilsolipuram]

The above post deleted the duplicate cells, this post will empty the duplicate cells instead of deleting it

Sub insertRows()
Dim st, en, g, k As Variant
g = 0
k = 1
Dim curcell, nextcell As Range
ActiveSheet.Range("A1").Select
Do Until IsEmpty(ActiveCell)
Set curcell = ActiveCell
Set nextcell = ActiveCell.Offset(1, 0)
ActiveCell.Offset(1, 0).Select
If nextcell.Value <> curcell.Value Then
If g = 1 Then
en = ActiveCell.Row - 1
Range("a" & (st) & ":a" & en).Select
Selection.Copy

Range("c" & st).Select
ActiveSheet.Paste
Range("a" & st & ":a" & en).Select
Selection.ClearContents
nextcell.Offset(1, 0).Select

en = ActiveCell.Row - 1
k = 1
ActiveCell.Offset(-(en - (st + 1)), 0).Select
End If
g = 0
Else
If g = 0 Then
st = ActiveCell.Row - 1
End If
k = k + 1
g = 1

End If
Loop
End Sub

[DaveUK]

Thanks better but still not quite working as hoped.

If there are numbers as this:

3
4
6
6
6
6
24
45
45
45
64
64
245
245
456
3748
5677

then i expected in the A column

3
4
24
45
456
3748
5677

& In the C Column

6
6
6
6
45
45
64
64
245
245

If that makes sense.

What your code gave is in the A column:

3
4
24
45
64
64
456
3748
5677


& in the C column:

6
6
45
45
245
245


Thanks again for your help

[anilsolipuram]

That was clear explanation

This should solve your problem.

Sub insertRows()
Dim st, en, g, k As Variant
g = 0
k = 1
Dim curcell, nextcell As Range
ActiveSheet.Range("A1").Select
Do Until IsEmpty(ActiveCell)
Set curcell = ActiveCell
Set nextcell = ActiveCell.Offset(1, 0)
ActiveCell.Offset(1, 0).Select
If nextcell.Value <> curcell.Value Then
If g = 1 Then
en = ActiveCell.Row - 1
Range("a" & (st) & ":a" & en).Select
Selection.Copy

Range("c" & st).Select
If Range("c" & st).Value <> "" Then
Range("c" & st).End(xlDown).Offset(1, 0).Select
Else
End If
ActiveSheet.Paste
Range("a" & st & ":a" & en).Select
Selection.Delete Shift:=xlUp
nextcell.Offset(1, 0).Select

en = ActiveCell.Row - 1
k = 1
ActiveCell.Offset(-((en + 1) - (st)), 0).Select
MsgBox ActiveCell.Row
End If
g = 0
Else
If g = 0 Then
st = ActiveCell.Row - 1
End If
k = k + 1
g = 1

End If
Loop
End Sub