Help merging like rows into one row

[trey2008]

I need some help writing a macro that will combine duplicate entries and delete out one of the entries. Please see table below: In below table I would like to combine the two entries for 123 on one row displaying all three reasons. I have a lot of data, so it would need to be a macro. Any help is appreciated

Request	Reason1	Reason2	Reason3
123	a	b
123	c
564	a
432	a	b

<tbody>
</tbody>

I found this but it combines my reasons in the same cell with a space in-between each value. But this code is too advanced for me to pick apart .

<code class="vb plain">CombineRows()</code>
<code class="vb comments">'Update 20131202</code>
<code class="vb keyword">Dim</code> <code class="vb plain">WorkRng </code><code class="vb keyword">As</code> <code class="vb plain">Range</code>
<code class="vb keyword">Dim</code> <code class="vb plain">Dic </code><code class="vb keyword">As</code> <code class="vb keyword">Variant</code>
<code class="vb keyword">Dim</code> <code class="vb plain">arr </code><code class="vb keyword">As</code> <code class="vb keyword">Variant</code>
<code class="vb keyword">On</code> <code class="vb keyword">Error</code> <code class="vb keyword">Resume</code> <code class="vb keyword">Next</code>
<code class="vb plain">xTitleId = </code><code class="vb string">"KutoolsforExcel"</code>
<code class="vb keyword">Set</code> <code class="vb plain">WorkRng = Application.Selection</code>
<code class="vb keyword">Set</code> <code class="vb plain">WorkRng = Application.InputBox(</code><code class="vb string">"Range"</code><code class="vb plain">, xTitleId, WorkRng.Address, Type:=8)</code>
<code class="vb keyword">Set</code> <code class="vb plain">Dic = CreateObject(</code><code class="vb string">"Scripting.Dictionary"</code><code class="vb plain">)</code>
<code class="vb plain">arr = WorkRng.Value</code>
<code class="vb keyword">For</code> <code class="vb plain">i = 1 </code><code class="vb keyword">To</code> <code class="vb plain">UBound(arr, 1)</code>
<code class="vb spaces"> </code><code class="vb plain">xvalue = arr(i, 1)</code>
<code class="vb spaces"> </code><code class="vb keyword">If</code> <code class="vb plain">Dic.Exists(xvalue) </code><code class="vb keyword">Then</code>
<code class="vb spaces"> </code><code class="vb plain">Dic(arr(i, 1)) = Dic(arr(i, 1)) & </code><code class="vb string">" "</code> <code class="vb plain">& arr(i, 2)</code>
<code class="vb spaces"> </code><code class="vb keyword">Else</code>
<code class="vb spaces"> </code><code class="vb plain">Dic(arr(i, 1)) = arr(i, 2)</code>
<code class="vb spaces"> </code><code class="vb keyword">End</code> <code class="vb keyword">If</code>
<code class="vb keyword">Next</code>
<code class="vb plain">Application.ScreenUpdating = </code><code class="vb keyword">False</code>
<code class="vb plain">WorkRng.ClearContents</code>
<code class="vb plain">WorkRng.Range(</code><code class="vb string">"A1"</code><code class="vb plain">).Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.keys)</code>
<code class="vb plain">WorkRng.Range(</code><code class="vb string">"B1"</code><code class="vb plain">).Resize(Dic.Count, 1) = Application.WorksheetFunction.Transpose(Dic.items)</code>
<code class="vb plain">Application.ScreenUpdating = </code><code class="vb keyword">True</code>
<code class="vb keyword">End</code> <code class="vb keyword">Sub</code>

 

[mumps]

Try:

Sub mergeLikeRows2()
    Application.ScreenUpdating = False
    Dim LastRow As Long
    LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
    Dim request As Range, rng As Range
    Dim secVisRow As Long
    Dim lCol As Long
    Sheets("Sheet1").Range("A1:A" & LastRow).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A1:A" & LastRow), Unique:=True
    Set rnguniques = Sheets("Sheet1").Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
    For Each request In rnguniques
        Range("A1:A" & LastRow).AutoFilter Field:=1, Criteria1:=request
        secVisRow = Range("A2", Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row + 1
        For Each rng In Range("A" & secVisRow & ":A" & LastRow).SpecialCells(xlCellTypeVisible)
            lCol = Cells(secVisRow - 1, Columns.Count).End(xlToLeft).Column + 1
            Range(Cells(rng.Row, 2), Cells(rng.Row, lCol)).Copy Cells(secVisRow - 1, lCol)
            'rng.EntireRow.Delete
        Next rng
    Next request
    If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
    lCol = Cells(1, Columns.Count).End(xlToLeft).Column
    Range(Cells(1, 1), Cells(LastRow, lCol)).RemoveDuplicates Columns:=1, Header:=xlYes
    Application.ScreenUpdating = True
End Sub

 

[trey2008]

Thanks Mumps, this is definitely closer. I made a few changes, but when I run it now, it not only grabs the duplicate request reasons, but also the non duplicate request reasons. For the example above on request 123 I would now have a,b,c,a,a,b as reasons.

Sub mergeLikeRows2()
Application.ScreenUpdating = False
Dim LastRow As Long
LastRow = Cells.Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row
Dim request As Range, rng As Range
Dim secVisRow As Long
Dim lCol As Long
Sheets("Sheet1").Range("A2:A" & LastRow).AdvancedFilter Action:=xlFilterInPlace, CriteriaRange:=Range("A2:A" & LastRow), Unique:=True
Set rnguniques = Sheets("Sheet1").Range("A2:A" & LastRow).SpecialCells(xlCellTypeVisible)
For Each request In rnguniques
Range("A1:A" & LastRow).AutoFilter Field:=1, Criteria1:=request
secVisRow = Range("A2", Cells(Rows.Count, "A").End(xlUp)).SpecialCells(xlCellTypeVisible).Cells(1, 1).Row + 1
For Each rng In Range("A" & secVisRow & ":A" & LastRow).SpecialCells(xlCellTypeVisible)
lCol = Cells(secVisRow - 1, Columns.Count).End(xlToLeft).Column + 1
Range(Cells(rng.Row, 2), Cells(rng.Row, lCol)).Copy Cells(secVisRow - 1, lCol)
'rng.EntireRow.Delete
Next rng
Next request
If ActiveSheet.AutoFilterMode = True Then ActiveSheet.AutoFilterMode = False
lCol = Cells(1, Columns.Count).End(xlToLeft).Column
Range(Cells(1, 1), Cells(LastRow, lCol)).RemoveDuplicates Columns:=1, Header:=xlYes
Application.ScreenUpdating = True
End Sub

 

[mumps]

I tried the macro on some dummy data and it worked as you requested. What changes did you make? Unless I'm missing something, the macro you posted looks the same as the one I suggested. Also, when posting code, please use code tags. You can do this by highlighting the code and then clicking the # sign in the menu at the top of the response window. By the way, you can delete the following line of code:

 'rng.EntireRow.Delete