Copy identical cell contents to "Sheet1" Column A

DaveUK

Board Regular
Joined
Jan 24, 2005
Messages
245
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!!
 

Excel Facts

Control Word Wrap
Press Alt+Enter to move to a new row in a cell. Lets you control where the words wrap.

tactps

Well-known Member
Joined
Jan 20, 2004
Messages
3,460
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

Board Regular
Joined
Jan 24, 2005
Messages
245
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

Board Regular
Joined
Jan 24, 2005
Messages
245
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

Well-known Member
Joined
Jan 20, 2004
Messages
3,460

ADVERTISEMENT

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

Board Regular
Joined
Jan 24, 2005
Messages
245
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
 

Nimrod

MrExcel MVP
Joined
Apr 29, 2002
Messages
6,259
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

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

Forum statistics

Threads
1,148,216
Messages
5,745,436
Members
423,951
Latest member
peggrif

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Top