Convert Data Layout

[KForrest42]

I currently have a three columns of data which I need to convert to a different layout using VBA.

I need to go from this:

Tag	Drawing	Drawing Type
1	I1	IFC
1	I2	IFC
1	R1	Redline
1	B1	Bootleg
2	I3	IFC
2	R2	Redline
2	B2	Bootleg
3	I4	IFC
4	R3	Redline
5	I5	IFC
5	B3	Bootleg
5	D1	Detail
6	I6	IFC
6	I7	IFC
6	R4	Redline
6	R5	Redline
6	B4	Bootleg

<tbody>
</tbody>

To this:

Tag	IFC	IFC	Redline	Redline	Bootleg	Detail
1	I1	I2	R1		B1
2	I3		R2		B2
3	I4
4			R3
5	I5				B3	D1
6	I6	I7	R4	R5	B4

<tbody>
</tbody>

The duplicates are removed from the "Tag" column, but if there are duplicates in the "Drawing Type" column for that tag, new columns need to be added to accommodate the different drawing numbers. Any help would be appreciated. Thanks

 

[MickG]

Try this for results on sheet2 starting "A1".

[COLOR="Navy"]Sub[/COLOR] MG24Nov23
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dic         [COLOR="Navy"]As[/COLOR] Object
[COLOR="Navy"]Dim[/COLOR] Q           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] n           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Rw          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] Ac          [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] k           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] p           [COLOR="Navy"]As[/COLOR] Variant
[COLOR="Navy"]Dim[/COLOR] c           [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
[COLOR="Navy"]Dim[/COLOR] R           [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] col         [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
   
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.Count).End(xlUp))
 [COLOR="Navy"]Set[/COLOR] Dic = CreateObject("Scripting.Dictionary")
    Dic.CompareMode = 1
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
            [COLOR="Navy"]If[/COLOR] Not Dic.Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] Dic(Dn.Value) = CreateObject("Scripting.Dictionary")
            [COLOR="Navy"]End[/COLOR] If
        
        [COLOR="Navy"]If[/COLOR] Not Dic(Dn.Value).Exists(Dn.Offset(, 2).Value) [COLOR="Navy"]Then[/COLOR]
                Dic(Dn.Value).Add (Dn.Offset(, 2).Value), Array(1, Dn)
        [COLOR="Navy"]Else[/COLOR]
                Q = Dic(Dn.Value).Item(Dn.Offset(, 2).Value)
                    Q(0) = Q(0) + 1
                    [COLOR="Navy"]Set[/COLOR] Q(1) = Union(Q(1), Dn)
                Dic(Dn.Value).Item(Dn.Offset(, 2).Value) = Q
         [COLOR="Navy"]End[/COLOR] If
    [COLOR="Navy"]Next[/COLOR] Dn
   
[COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
.CompareMode = vbTextCompare
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.keys
        c = c + 1
       [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(k)
            [COLOR="Navy"]If[/COLOR] Not .Exists(p) [COLOR="Navy"]Then[/COLOR]
                .Add p, Array(Dic(k).Item(p)(0), 0)
            [COLOR="Navy"]Else[/COLOR]
                Q = .Item(p)
                    Q(0) = Application.Max(Q(0), Dic(k).Item(p)(0))
                .Item(p) = Q
            [COLOR="Navy"]End[/COLOR] If
        [COLOR="Navy"]Next[/COLOR] p
    [COLOR="Navy"]Next[/COLOR] k
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] .keys
        [COLOR="Navy"]For[/COLOR] n = 1 To .Item(k)(0)
            c = c + 1
            Q = .Item(k)
                [COLOR="Navy"]If[/COLOR] Q(1) = 0 [COLOR="Navy"]Then[/COLOR] Q(1) = c
            .Item(k) = Q
       [COLOR="Navy"]Next[/COLOR] n
    [COLOR="Navy"]Next[/COLOR] k
ReDim Ray(1 To Dic.Count + 1, 1 To c)
Ray(1, 1) = "Tag"
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] k [COLOR="Navy"]In[/COLOR] Dic.keys
        Rw = Rw + 1
            [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] p [COLOR="Navy"]In[/COLOR] Dic(k)
                Ac = .Item(p)(1): col = 0
                [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] R [COLOR="Navy"]In[/COLOR] Dic(k).Item(p)(1)
                    Ray(1, Ac + col) = p
                    Ray(Rw + 1, 1) = k
                    Ray(Rw + 1, Ac + col) = R.Offset(, 1).Value
                    col = col + 1
                [COLOR="Navy"]Next[/COLOR] R
            [COLOR="Navy"]Next[/COLOR] p
    [COLOR="Navy"]Next[/COLOR] k
[COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]With[/COLOR] Sheets("Sheet4").Range("A1").Resize(UBound(Ray, 1), UBound(Ray, 2))
    .Value = Ray
    .Borders.Weight = 2
    .Columns.AutoFit
 [COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[KForrest42]

That's amazing! Thank you. All I had to change was Sheet4 to Sheet2 in the last with statement.

 

[MickG]

You're welcome