Thread: Find duplicates and merge adjacent data for number of that duplicate into one cell

Just so we're not hoping, create a workbook with BEFORE/AFTER examples of about 25 rows showing all the variables that would occur in your larger data set. With that, we should be able to offer a good macro to do this for you.

Click GO ADVANCED and use the paperclip icon to post up a copy of your workbook.

Give this a try:

Option Explicit

Sub MergeIDs()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim RNG As Range
Dim cel As Range
Dim LR  As Long
Dim i   As Long
Dim MyArr As Variant

If MsgBox("Process the active sheet and merge the Position IDs by Position Title?", _
                                        vbYesNo, "This sheet?") = vbNo Then Exit Sub
If ActiveSheet.Name = "After" Then
    MsgBox "This sheet is not a raw data sheet."
    Exit Sub
End If

Set ws1 = ActiveSheet

Application.ScreenUpdating = False

If Not Evaluate("=ISREF(After!A1)") Then
    Worksheets.Add(after:=ws1).Name = "After"
Else
    Sheets("After").UsedRange.Clear
End If

Set ws2 = Sheets("After")

For Each cel In ws1.Range("B:B").SpecialCells(xlConstants)
    cel.Value = Trim(cel.Value)
Next cel

ws1.Range("B:B").AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=ws2.Range("B1"), Unique:=True
LR = ws2.Range("B" & ws2.Rows.Count).End(xlUp).Row
Set RNG = ws2.Range("B2:B" & LR)

With ws1
    .AutoFilterMode = False
    LR = .Range("B" & .Rows.Count).End(xlUp).Row
    .Range("B:B").AutoFilter
    
    For Each cel In RNG
        .Range("B:B").AutoFilter 1, cel.Text
        MyArr = Application.WorksheetFunction.Transpose(ws1.Range("A2:A" & LR).SpecialCells(xlVisible).Cells)
        If VarType(MyArr) = 5 Then
            ws2.Range("A" & cel.Row & ",C" & cel.Row) = MyArr
        Else
            ws2.Range("A" & cel.Row).Value = MyArr(1)
            ws2.Range("C" & cel.Row).Value = Join(MyArr, Chr(10))
        End If
    Next cel
    
    .AutoFilterMode = False
End With

With ws2
    With .Range("A1:C1")
        .Font.Bold = True
        .Interior.ColorIndex = 46
        .VerticalAlignment = xlBottom
        .Value = [{"Position ID","Position Title","Position IDs"}]
    End With
    .Activate
    .Columns("A:A").VerticalAlignment = xlTop
    .Columns("B:B").ColumnWidth = 200
    .Columns.AutoFit
    .Range("C:C").HorizontalAlignment = xlLeft
    .Range("A1").CurrentRegion.Borders.Weight = xlThin
    .Range("A2").Select
    ActiveWindow.FreezePanes = True
End With

Application.ScreenUpdating = True
End Sub

Hi Jerry, just deleted the contractor ones with letters in the position ID's and it worked. Its very impressive. Anyway is there any chance you might be able to update the code to allow letters in ID?

Thanks
Sal.

I can't see anything offhand that would object to any particular IDs. You can, of course, post an updated sample sheet BEFORE/AFTER that more accurately depicts your needs if it differs so much the macro stopped working. I'll be happy to look at it again.

First, I removed the macro from the ThisWorkbook module, it does not belong there. It goes in a standard code module (Insert > Module).

Here's the corrected code, it appears your text values DO create a different vartype, so I added that.

Option Explicit

Sub MergeIDs()
Dim ws1 As Worksheet
Dim ws2 As Worksheet
Dim RNG As Range
Dim cel As Range
Dim LR  As Long
Dim i   As Long
Dim MyArr As Variant

If MsgBox("Process the active sheet and merge the Position IDs by Position Title?", _
                                        vbYesNo, "This sheet?") = vbNo Then Exit Sub
If ActiveSheet.Name = "After" Then
    MsgBox "This sheet is not a raw data sheet."
    Exit Sub
End If

Set ws1 = ActiveSheet

Application.ScreenUpdating = False

If Not Evaluate("=ISREF(After!A1)") Then
    Worksheets.Add(after:=ws1).Name = "After"
Else
    Sheets("After").UsedRange.Clear
End If

Set ws2 = Sheets("After")

For Each cel In ws1.Range("B:B").SpecialCells(xlConstants)
    cel.Value = Trim(cel.Value)
Next cel

ws1.Range("B:B").AdvancedFilter Action:=xlFilterCopy, _
    CopyToRange:=ws2.Range("B1"), Unique:=True
LR = ws2.Range("B" & ws2.Rows.Count).End(xlUp).Row
Set RNG = ws2.Range("B2:B" & LR)

With ws1
    .AutoFilterMode = False
    LR = .Range("B" & .Rows.Count).End(xlUp).Row
    .Range("B:B").AutoFilter
    
    For Each cel In RNG
        .Range("B:B").AutoFilter 1, cel.Text
        MyArr = Application.WorksheetFunction.Transpose(ws1.Range("A2:A" & LR).SpecialCells(xlVisible).Cells)
        If VarType(MyArr) = 5 Or VarType(MyArr) = 8 Then
            ws2.Range("A" & cel.Row & ",C" & cel.Row) = MyArr
        Else
            ws2.Range("A" & cel.Row).Value = MyArr(1)
            ws2.Range("C" & cel.Row).Value = Join(MyArr, Chr(10))
        End If
    Next cel
    
    .AutoFilterMode = False
End With

With ws2
    With .Range("A1:C1")
        .Font.Bold = True
        .Interior.ColorIndex = 46
        .VerticalAlignment = xlBottom
        .Value = [{"Position ID","Position Title","Position IDs"}]
    End With
    .Activate
    .Columns("B:B").ColumnWidth = 200
    .Columns.AutoFit
    .Columns("A:C").VerticalAlignment = xlTop
    .Range("A:C").HorizontalAlignment = xlLeft
    .Range("A1").CurrentRegion.Borders.Weight = xlThin
    .Range("A2").Select
    ActiveWindow.FreezePanes = True
End With

Application.ScreenUpdating = True
End Sub

If that takes care of your need, please click EDIT in your original post, click GO ADVANCED and set the PREFIX box to SOLVED.