VBA. identify in different rows if data is the same in one cell and give same serial number

[Ambre]

Dear all,

What I am trying to do is:
When two rows have the same Project ID, then they have the same serial number.
I could have 2 or more rows with the same project ID.

Cannot write a code that works. I think the best is to use If Then Else.

See the tables below for better understanding.

Many thanks for your help.

Ambre
Excel 2010
Windows XP

What I have
Serial number	AAA	BBB	Project ID	Project Name
1320	AL	BBBC	EXAMPLE0123	ALA
1319	AM	BBBD	EXAMPLE0124	ABA
1318	AN	BBBE	EXAMPLE0125	ACA
1317	AO	BBBE	EXAMPLE0126	AKA
1316	AP	BBBA	EXAMPLE0127	APA
1315	AQ	BBBC	EXAMPLE0123	AAL
1314	AR	BBBD	EXAMPLE0129	ANA
1313	AS	BBBF	EXAMPLE0130	ARA
What I would like (forget about the color it was only to show what is important)
Serial number	AAA	BBB	Project ID	Project Name
1315	AL	BBBC	EXAMPLE0123	ALA
1319	AM	BBBD	EXAMPLE0124	ABA
1318	AN	BBBE	EXAMPLE0125	ACA
1317	AO	BBBE	EXAMPLE0126	AKA
1316	AP	BBBA	EXAMPLE0127	APA
1315	AQ	BBBC	EXAMPLE0123	AAL
1314	AR	BBBD	EXAMPLE0129	ANA
1313	AS	BBBF	EXAMPLE0130	ARA

<TBODY>
</TBODY>

 

[Ambre]

My try, at least the beggining

Public Sub test()

'identify column
Dim ProjectID As Integer
Dim ProjectID_column As Integer
For ProjectID = 1 To 200
If Worksheets("Purchasing Plan").Cells(11, ProjectID) = "Project ID" Then
ProjectID_column = ProjectID
End If

Next

Dim dataRange As Range
Dim oneCell As Range
Set dataRange = Range(.Cells(15, ProjectID_column), .Cells(.Rows.Count, 15).End(xlUp))

I do not know what do to next and I could not find the solution in the forums I visited

 

[Ambre]

Any ideas?

 

[jaslake]

Hi Ambre

Try this

Option Explicit
Sub Find_Dups()
    Dim LR As Long
    Dim Rng As Range, Cel As Range
    Dim ws As Worksheet
    Set ws = Sheets("Sheet1") '<----Change Sheet Name as required
    With ws
        LR = .Cells.Find("*", .Cells(.Rows.Count, .Columns.Count), SearchOrder:=xlByRows, _
                SearchDirection:=xlPrevious).Row
        .Sort.SortFields.Clear
        .Sort.SortFields.Add Key:=Range("D2:D" & LR), _
                SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
        With .Sort
            .SetRange Range("A1:E" & LR)
            .Header = xlYes
            .MatchCase = False
            .Orientation = xlTopToBottom
            .SortMethod = xlPinYin
            .Apply
        End With
        For Each Cel In .Range("D2:D" & LR)
            If Cel.Value = Cel.Offset(1, 0).Value Then
                Cel.Offset(1, -3).Value = Cel.Offset(0, -3).Value
            End If
        Next Cel
    End With
End Sub