Macro to find matching numbers in column A and replace all row cells of the original number with row cell of the matching number

[ener]

Sample:

Column A	Column B	Column C	Column D	Comments
101	aaaaa	bbbbb	ccccc	ddddd
105	eeeee	fffff	ggggg	hhhhh
103	jjjjj	kkkkk	lllll	zzzzz
157	xxxxx	ccccc	vvvvv	bbbbb
133	nnnnn	mmmmm	qqqqq	wwwww
105	eeeee	fffff	ggggg
101	aaaab	bbbbb	ccccc
157	xxxxx	ccccc	vvvvv
133	nnnnn	mmmmm	qqqqq
122	aaabb	bbbcc	cccdd

<tbody>
</tbody>

---

What it should look like at the end:

Column A Column B Column C Column D Comments 101 aaaab bbbbb ccccc ddddd 105 eeeee fffff ggggg hhhhh 103 jjjjj kkkkk lllll zzzzz 157 xxxxx ccccc vvvvv bbbbb 133 nnnnn mmmmm qqqqq wwwww 122 aaabb bbbcc cccdd <tbody> </tbody>

<tbody>
</tbody>

Hi Guys,
I really hope someone can help. I am just starting to learn VB but as I have very little time to study it would probably take a few months before I could write the code. This could be very difficult or very simple. Not quite sure.

What I need:
1st compare all numbers in Column A beginning with A2 and if number appears again further down copy all the information from that row into relevant Columns where the first number was

It's easier with an example: Cell A2 has the number 101 in it. Now we need to check A3, A4 A5 etc to see if the number 101 appears again. It does so in Cell A8. Now I would need the Info contained in B8 copied to B2, C8 to C2, D8 to D2. The information in the E column (Comments) should not be overwritten so no copying E8 to E2 is necessary. After that is done complete ROW 8 should be deleted.

Then A3 which contains number 105 should be checked for a another A column that also contains 105. It does so in A7 and we again copy all the info from that this row to Row 3. Once again ignoring the Comment Column . After all the info is copied Row 7 can be deleted.

That needs to be continued for all the other numbers in Column A until there are no numbers left.
There are some circumstances where a number in Column A is there only once. Eg. Cell A4 contains number 103 and there is no other number 103 anywhere in Column A. If that happens the row should be marked all red (or highlighted in some other way) so I can check that particular number manually.
That case also happens for cell A11 that has number 122 which also appears only once. Again that whole column would need to be marked somehow (either color or any other feature) so I can look at that one manually.

You can see what it should look like at the end in my sample.

Here is some additional info:

This is all very simplified. There are many more rows and columns than this but usually I can adjust the code depending on the amount of columns /rows. There are usually no more than 200 rows though.
The columns contain different data sets such as numbers, dates and formulas. Not sure if that makes any difference when copying data from one row to another.
Sometimes there are no changes at all or everything changed.
The most amount of matching numbers are 2. Never more but sometimes there is only a single number as explained above.

 

[Teeroy]

Hi ener,

I think the following matches your requirement.

Sub Update_data()
Dim rTest As Range, rSearch As Range, rResult As Range

With ActiveSheet
    Set rTest = .Range("A2")
    Do
    Set rSearch = Range(rTest, .Range("A" & .Rows.Count).End(xlUp))
    Set rResult = rSearch.Find(What:=rTest, After:=rTest, LookIn:=xlValues, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
    If rResult.Address <> rTest.Address Then
        rResult.Offset(0, 1).Resize(1, 3).Copy rTest.Offset(0, 1).Resize(1, 3)
        rResult.EntireRow.Delete
    End If
    Set rTest = rTest.Offset(1, 0)
    Loop While rTest.Row < .Range("A" & .Rows.Count).End(xlUp).Row
End With
End Sub

 

[ener]

Hi ener,

I think the following matches your requirement.

Sub Update_data()
Dim rTest As Range, rSearch As Range, rResult As Range

With ActiveSheet
    Set rTest = .Range("A2")
    Do
    Set rSearch = Range(rTest, .Range("A" & .Rows.Count).End(xlUp))
    Set rResult = rSearch.Find(What:=rTest, After:=rTest, LookIn:=xlValues, LookAt:= _
        xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
        , SearchFormat:=False)
    If rResult.Address <> rTest.Address Then
        rResult.Offset(0, 1).Resize(1, 3).Copy rTest.Offset(0, 1).Resize(1, 3)
        rResult.EntireRow.Delete
    End If
    Set rTest = rTest.Offset(1, 0)
    Loop While rTest.Row < .Range("A" & .Rows.Count).End(xlUp).Row
End With
End Sub

Thank you so much Teeroy for the Code. I will check it tomorrow and Monday I can run it with the actual file I have at work which contains a lot more entries (columns/rows) and I will let you know.

I really appreciate your effort.

Thanks again.

 

[ener]

Hi Teeroy or anyone else. I did run the code but the end result is not quite correct. Here is the result I received:

Column A	Column B	Column C	Column D	Column E
101	aaaaa	bbbbb	ccccc	ddddd
105	eeeee	fffff	ggggg	hhhhh
103	jjjjj	kkkkk	lllll	zzzzz
157	xxxxx	ccccc	vvvvv	bbbbb
133	nnnnn	mmmmm	qqqqq	wwwww
122	aaabb	bbbcc	cccdd	dddee

<tbody>
</tbody>

Please see again what it should look like below:

Column A	Column B	Column C	Column D	Comments
101	aaaab	bbbbb	ccccc	ddddd
105	eeeee	fffff	ggggg	hhhhh
103	jjjjj	kkkkk	lllll	zzzzz
157	xxxxx	ccccc	vvvvv	bbbbb
133	nnnnn	mmmmm	qqqqq	wwwww
122	aaabb	bbbcc	cccdd

<tbody>
</tbody>

Cell B2 should say aaaab as cell C8 has that info in there. So the newer information are always in the 2nd matching number it finds. So Row 8 (101) has newer info than Row 2 (101), Row 7 has newer info than Row 3 (105) etc. etc.

Also, Row 7 in the results (122) should not have any comments in there at all as there were no comments in there at all in the first place and no other matching number 122 in the spreadsheet.

Lastly and I am not 100% sure if that is possible could row A3 (103) and A7 (122) be marked/highlighted somehow such as red font color as those numbers are listed only once in the original data (no 2nd matching number)

know you already spend time on this and it would be great if you could have a 2nd look but as I said if it's too much work I will figure it out eventually.

Thanks again.

P.S. Hope the code works the same in all Excel versions. I am running Excel 2007

 

[Teeroy]

I have run the code on both excel2003 and excel2010 and get the correct results (same as you've posted). I don't understand how you got the first results as the last comment (E7) is not even included in the test data that you supplied. The one thing I can think of that may cause an issue is if you have a space after the number in a cell in column A, since that's not a whole match. Anyway I've added the font change below, please try it and let me know how you go.

Sub Update_data()
Dim rTest As Range, rSearch As Range, rResult As Range
With ActiveSheet
    Set rTest = .Range("A2")
    Do
        Set rSearch = Range(rTest, .Range("A" & .Rows.Count).End(xlUp))
        Set rResult = rSearch.Find(What:=rTest, After:=rTest, LookIn:=xlValues, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False)
        If rResult.Address <> rTest.Address Then
            rResult.Offset(0, 1).Resize(1, 3).Copy rTest.Offset(0, 1).Resize(1, 3)
            rResult.EntireRow.Delete
        Else
            rTest.Resize(1, 5).Font.Color = vbRed
        End If
        Set rTest = rTest.Offset(1, 0)
    Loop While rTest.Row < .Range("A" & .Rows.Count).End(xlUp).Row
End With
End Sub

 

[ener]

Awesome, its working now.

Only thing is Row 7 with the number 122 is not highlited in red like row 3 (103). Maybe that could be added. Otherwise this is great. I will run it for the actual Excel sheet a bit later which has more rows and columns but the principle is always the same. Thanks again so much.

Below is the one line that didn't get marked red (122 appears only once in column A) so hopefully only a minor change is needed.

122</SPAN>

aaabb</SPAN>

bbbcc</SPAN>

cccdd

<TBODY>
</TBODY>

 

[Teeroy]

Hi Ener,
My fault, I forgot that the last row (which isn't searched) could be a loner. I've added a final test that fixes it.

Sub Update_data()
Dim rTest As Range, rSearch As Range, rResult As Range
With ActiveSheet
    Set rTest = .Range("A2")
    Do
        Set rSearch = Range(rTest, .Range("A" & .Rows.Count).End(xlUp))
        Set rResult = rSearch.Find(What:=rTest, After:=rTest, LookIn:=xlValues, LookAt:= _
            xlWhole, SearchOrder:=xlByRows, SearchDirection:=xlNext, MatchCase:=False _
            , SearchFormat:=False)
        If rResult.Address <> rTest.Address Then
            rResult.Offset(0, 1).Resize(1, 3).Copy rTest.Offset(0, 1).Resize(1, 3)
            rResult.EntireRow.Delete
        Else
            rTest.Resize(1, 5).Font.Color = vbRed
        End If
        Set rTest = rTest.Offset(1, 0)
        If rTest.Row = .Range("A" & .Rows.Count).End(xlUp).Row Then
            rTest.Resize(1, 5).Font.Color = vbRed
        End If
    Loop While rTest.Row < .Range("A" & .Rows.Count).End(xlUp).Row
End With
End Sub

 

[ener]

Hi Teeroy,

Working perfectly now. I will be able to test it on some of my actual documents over the next few days but as I said only difference is that there are a few more columns and rows so hopefully I will be able to adjust the code myself.


Thanks so much for all your help. I owe you a beer