Loop through Duplicates and combine data to 1 row

[drose1105]

Hi,

I have a spreadsheet that contains Duplicate ID's. My goal here is to find the duplicates within Column A and then cut the data from Column #21 up to the 1st duplicate, then delete the 2nd duplicate so that I end up with only 1 ID per Row - See Finished Product below.. I thought to insert Column B which is a simple if formula to compare ID's in Column A. Where there is no duplicate found, I do nothing & macro continues.

My issue is that the data i want to cut (Columns D-G) is sometimes located in Columns # 21/22 (see Row 4), other times, it's in Columns #23/24 (see Row 7). Also, I then have 4 duplicate ID's (Rows 8-11) where this macro is not working.

Ultimately, I want the spreadsheet to look like the "Finished Product" below so that there all the data in Columns #21-24 are combined into 1 Row so that there is only 1 ID per row. Please help

 

[mumps]

It is hard to work with pictures. It would be easier to help if you could use the XL2BB add-in (icon in the menu) to attach a screenshot (not a picture) of your sheet. Alternately, you could upload a copy of your file to a free site such as www.box.com or www.dropbox.com. Once you do that, mark it for 'Sharing' and you will be given a link to the file that you can post here. Explain in detail what you want to do referring to specific cells, rows, columns and sheets using a few examples from your data (de-sensitized if necessary).

 

[drose1105]

Hi - I was unable to get the .XL2BB to work so I put my spreadsheet in dropbox.com with the below link.

Mr Excel VBA Post.xlsx

Shared with Dropbox

www.dropbox.com

Here's what I want the macro to do; , Cells A3 & A4 are duplicate IDs. I want to go to cell D4 & E4, cut the data up 1 row to cells D3 & E3 and then delete Row 4. My problem is that sometimes the data I want to cut is located in column D&E (see Row 4), other times in F&G (see Row 7). Maybe we need to add some logic to see which cell contains text? In addition, where there no duplicate ID, I want it to continue to the next cell down and then find the next duplicate ID

. I put in Column B a simple if formula to identify the duplicate (=if(D3=D4,1,0) where 1 = Duplicate.

I hope this is clear.

 

[mumps]

Try:

Sub CombineData()
    Application.ScreenUpdating = False
    Dim i As Long, v As Variant
    v = Range("A3", Range("A" & Rows.Count).End(xlUp)).Resize(, 7).Value
    For i = UBound(v) To LBound(v) + 1 Step -1
        If v(i, 1) = v(i - 1, 1) Then
            If WorksheetFunction.CountA(Range("D" & i + 2).Resize(, 4)) = 4 Then
                Range("D" & i + 2).Resize(, 4).Copy Range("D" & i + 1)
                Rows(i + 2).Delete
            ElseIf v(i, 4) <> "" Then
                Range("D" & i + 2).Resize(, 2).Copy Range("D" & i + 1)
                Rows(i + 2).Delete
            ElseIf v(i, 6) <> "" Then
                Range("F" & i + 2).Resize(, 2).Copy Range("F" & i + 1)
                Rows(i + 2).Delete
            End If
        End If
    Next i
    Range("B3", Range("B" & Rows.Count).End(xlUp)).Formula = "=IF(A2=A1,1,0)"
    Application.ScreenUpdating = True
End Sub

 

[drose1105]

This is exactly what I wanted and it works perfectly.

You are a genius. Thanks so much!!

 

[drose1105]

One other question, my column set has now been changed - see attached Dropbox file.

Can you modify your macro for this?

I tried, but couldn't figure it out. Thanks

Mr Excel VBA Post2.xlsx

Shared with Dropbox

www.dropbox.com

 

[drose1105]

My entire worksheet range is from columns A to AF

Rows vary depending on how much data is dowloaded

 

[mumps]

Try:

Sub CombineData()
    Application.ScreenUpdating = False
    Dim i As Long, v As Variant
    v = Range("A2", Range("A" & Rows.Count).End(xlUp)).Resize(, 32).Value
    For i = UBound(v) To LBound(v) + 1 Step -1
        If v(i, 32) = v(i - 1, 32) Then
            If WorksheetFunction.CountA(Range("Y" & i + 1).Resize(, 4)) = 4 Then
                Range("Y" & i + 1).Resize(, 4).Copy Range("Y" & i)
                Rows(i + 1).Delete
            ElseIf v(i, 25) <> "" Then
                Range("Y" & i + 1).Resize(, 2).Copy Range("Y" & i)
                Rows(i + 1).Delete
            ElseIf v(i, 27) <> "" Then
                Range("AA" & i + 1).Resize(, 2).Copy Range("AA" & i)
                Rows(i + 1).Delete
            End If
        End If
    Next i
    Application.ScreenUpdating = True
End Sub

 

[drose1105]

worked perfectly.

You are the Best.

Thanks again!!

 

[mumps]

You are very welcome.