Merge cells from different rows depending on certain criteria

[gemf89]

Hello. I have been looking for an answer but obviously it is hard to find a case exactly like mine and I dont have the technical nous to change anything without screwing it up. If you can help I will be very grateful.

I get an auto-generated spreadsheet from a software. This is a sales software where I can find many orders with different products and there is row for every product even in the same order. I need to merge those rows into only one for every order.

Original spreadsheet
[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Client[/TD]
[TD]Order No. [/TD]
[TD]Product[/TD]
[TD]Price[/TD]
[/TR]
[TR]
[TD]Robert[/TD]
[TD]001[/TD]
[TD]Apples[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Robert[/TD]
[TD]001[/TD]
[TD]Oranges[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]Max[/TD]
[TD]002[/TD]
[TD]Apples[/TD]
[TD]2[/TD]
[/TR]
[TR]
[TD]Max[/TD]
[TD]002[/TD]
[TD]Oranges[/TD]
[TD]1[/TD]
[/TR]
[TR]
[TD]Max[/TD]
[TD]003[/TD]
[TD]Apples[/TD]
[TD]2[/TD]
[/TR]
</tbody>[/TABLE]











What I need is to automatically detect every single order No. and merge those rows into one. Like these:

[TABLE="class: grid, width: 500, align: left"]
<tbody>[TR]
[TD]Client[/TD]
[TD]Order No. [/TD]
[TD]Product[/TD]
[TD]Price[/TD]
[/TR]
[TR]
[TD]Robert[/TD]
[TD]001[/TD]
[TD]Apples-Oranges[/TD]
[TD]2-1[/TD]
[/TR]
[TR]
[TD]Max[/TD]
[TD]002[/TD]
[TD]Apples-Oranges[/TD]
[TD]2-1[/TD]
[/TR]
[TR]
[TD]Max[/TD]
[TD]003[/TD]
[TD]Apples[/TD]
[TD]2[/TD]
[/TR]
</tbody>[/TABLE]








thank you!

 

[PCL]

See next code

Option Explicit


Sub MergeCells()
Const FR = 2
Dim DataDic   As Object
Set DataDic = CreateObject("Scripting.Dictionary")
Dim Rg As Range
Dim I  As Integer
Dim AAA, BBB
    Columns(4).Cells.NumberFormat = "@"
    For I = FR To Cells(Rows.Count, 1).End(3).Row
        With DataDic
            If (.exists(Cells(I, 1) & Cells(I, 2))) Then
                Cells(.Item(Cells(I, 1) & Cells(I, 2)), 3) = Cells(.Item(Cells(I, 1) & Cells(I, 2)), 3) & " - " & Cells(I, 3)
                Cells(.Item(Cells(I, 1) & Cells(I, 2)), 4) = Cells(.Item(Cells(I, 1) & Cells(I, 2)), 4) & " - " & Cells(I, 4)
                Cells(I, 1) = ""
            Else
                .Item(Cells(I, 1) & Cells(I, 2)) = I
            End If
            AAA = .keys: BBB = .items
        End With
    Next
    Columns(1).Cells.SpecialCells(xlCellTypeBlanks).EntireRow.Delete
    MsgBox ("Job Done")
End Sub