merging rows

[its_subu]

Hello

I have a huge list. My goal is to merge identical values in the list and move up the non identical in the merged list. In the example below at Id 10001 id name location etc are same. I want to merge all the same elements and move to fax number up so that so that the new row has all the unique elements including Fax and phone in the same row. Note that Fax and phone are in different rows.

This is the list I want to merge.

Book1.xls
	A	B	C	D	E	F	G	H
1	Id	Name	Location	address	state	Site no	phone	Fax
2	10001	John	BuildingA	1WestAve	NY	SITE00001	(000)999-2222
3	10001	John	BuildingA	1WestAve	NY	SITE00001		(111)222-4444
4	10002	peter	BuildingB	13KarelAvenue	NY	SITE00720	(111)222-3333
5	10002	peter	BuildingB	13KarelAvenue	NY	SITE00720		(111)384-2000
Sheet3

THE RESULT I NEED IS LIKE THIS. Identical rows are merged and non identical ones fax and phone are next to each other.

Book1.xls
	A	B	C	D	E	F	G	H
1	Result-Needed
2	Id	Name	Location	address	state	Siteno	phone	Fax
3	10001	John	BuildingA	1WestAve	NY	SITE00001	(000)999-2222	(111)222-4444
4	10002	peter	BuildingB	13KarelAvenue	NY	SITE00720	(111)222-3333	(111)384-2000
Sheet2

Any amount of help is appreciated!!!

 

[jindon]

Hi
try

Sub test()
Dim dic As Object, x, z
Dim a, i As Long, ii As Long
Set dic = CreateObject("Scripting.Dictionary")
With Sheets("sheet3")
    a = .Range("a1").CurrentRegion.Value
    For i = 2 To UBound(a, 1)
        For ii = 1 To 6: z = z & a(i, ii) & ":": Next
        If Not dic.exists(z) Then
            ReDim w(1 To 8)
            For iii = 1 To 8
                w(iii) = a(i, iii)
            Next
            dic.Add z, w
        Else
            w = dic(z)
            For ii = 7 To 8
                If Not IsEmpty(a(i, ii)) Then _
                    w(ii) = a(i, ii)
            Next
            dic(z) = w
        End If
        z = Empty
    Next
End With
x = dic.items: Erase a: Set dic = Nothing
With Sheets("sheet2")
    With .Range("a1")
        .CurrentRegion.ClearContents
        .Resize(, 8).Value = _
            Sheets("sheet3").Range("a1").Resize(, 8).Value
        For i = 0 To UBound(x)
            .Offset(i + 1).Resize(, UBound(x(i))) = x(i)
        Next
    End With
End With
Erase x
End Sub