Copy identical cell contents to "Sheet1" Column A

[DaveUK]

I have a long list of data in Column A of worksheet "Sheet1".

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 data in the A column.

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!!

 

[tactps]

How about:

Sub insertRows()
ActiveSheet.Range("A1").Select
Do Until IsEmpty(ActiveCell)
If ActiveCell.Offset(1, 0).Value <> ActiveCell.Value Then
ActiveCell.Offset(0, 2).ClearContents
Else
ActiveCell.Offset(0, 2).Formula = ActiveCell.Text
ActiveCell.Offset(1, 2).Formula = ActiveCell.Offset(1, 0).Text
ActiveCell.ClearContents
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub

Is that what you want?

 

[DaveUK]

Re: Copy identical cell contents to "Sheet1" Colum

Thanks for the reply. It didn't work quite how i need.

My column A data was:
6
6
7
8
11
11
11
11
44
54
78
96
636
7980

Which after running the macro gave In column A:


6
7
8



11
44
54
78
96
636
7980
and in Column C:

6



11
11
11

What i was aiming for was in Column A:



7
8




44
54
78
96
636
7980

and in column C:

6
6


11
11
11
11






Thanks again and any more help appreciated.

 

[DaveUK]

Re: Copy identical cell contents to "Sheet1" Colum

I have edited the code somewhat which does improve it somewhat:

Edited to:

Sub insertRows()
ActiveSheet.Range("A1").Select
Do Until IsEmpty(ActiveCell)
If ActiveCell.Offset(1, 0).Value <> ActiveCell.Value Then
ActiveCell.Offset(0, 2).ClearContents
Else
ActiveCell.Offset(0, 2).Formula = ActiveCell.Text
ActiveCell.Offset(1, 2).Formula = ActiveCell.Offset(1, 0).Text
ActiveCell.ClearContents
ActiveCell.Offset(1, 0).ClearContents
End If
ActiveCell.Offset(2, 0).Select
Loop
End Sub


BUT,

For some reason it misses some at the beginning.

I tried in A Column:

1
4
4
5
6
6
8
9
13
45
54
54
54
54
54
54
965
36789
48907

which then after running the edited macro gives this in column A:

1
4
4
5


8
9
13
45






965
36789
48907

(Obviously the 4's were missed by the macro)

and the C column contained:





6
6




54
54
54
54
54
54




Which is again right apart from it should read:


4
4

6
6




54
54
54
54
54
54




Any ideas???

 

[tactps]

How about:

Sub insertRows()
ActiveSheet.Range("A1").Select
StartHere:
Do Until IsEmpty(ActiveCell)
On Error GoTo NextBit:
If ActiveCell.Value <> ActiveCell.Offset(1, 0).Value And ActiveCell.Value <> ActiveCell.Offset(-1, 2).Value Then
ActiveCell.Offset(1, 0).Select
GoTo StartHere
End If
NextBit:
If ActiveCell.Offset(1, 0).Value <> ActiveCell.Value Then
ActiveCell.ClearContents
Else
ActiveCell.Offset(0, 2).Formula = ActiveCell.Text
ActiveCell.Offset(1, 2).Formula = ActiveCell.Offset(1, 0).Text
ActiveCell.ClearContents
End If
ActiveCell.Offset(1, 0).Select
Loop
End Sub

 

[DaveUK]

Re: Copy identical cell contents to "Sheet1" Colum

That works great. Thanks a lot m8.

Just a query though !!!

How come you used:

ActiveCell.Offset(0, 2).Formula = ActiveCell.Text
ActiveCell.Offset(1, 2).Formula = ActiveCell.Offset(1, 0).Text

instead of

ActiveCell.Offset(0, 2).Value = ActiveCell.Value
ActiveCell.Offset(1, 2).Value = ActiveCell.Value

I also forgot to mention btw that the data can be alphanumeric !!

Thanks again

 

[tactps]

Habit.

You're welcome

 

[Nimrod]

Re: Copy identical cell contents to "Sheet1" Colum

Here's another solution ...just for fun :wink:

Sub MoveDupes()
For Each StrVal In Columns("A:A").SpecialCells(xlCellTypeConstants, 3)
With Application.WorksheetFunction
If (.CountIf(Range("A:A"), StrVal.Value) + .CountIf(Range("C:C"), StrVal.Value)) > 1 Then
StrVal.Offset(0, 2).Value = StrVal.Value
StrVal.ClearContents
End If
End With
Next StrVal
End Sub

NOTE: This solution does not require that the Dupes be in sorted into groups.