Convert Data Layout

K

KForrest42

New Member
Joined
Sep 8, 2016
Messages
3
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:
[TABLE="width: 214"]
<tbody>[TR]
[TD]Tag
[/TD]
[TD]Drawing
[/TD]
[TD]Drawing Type
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]I1
[/TD]
[TD]IFC
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]I2
[/TD]
[TD]IFC
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]R1
[/TD]
[TD]Redline
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]B1
[/TD]
[TD]Bootleg
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]I3
[/TD]
[TD]IFC
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]R2
[/TD]
[TD]Redline
[/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]B2
[/TD]
[TD]Bootleg
[/TD]
[/TR]
[TR]
[TD]3
[/TD]
[TD]I4
[/TD]
[TD]IFC
[/TD]
[/TR]
[TR]
[TD]4
[/TD]
[TD]R3
[/TD]
[TD]Redline
[/TD]
[/TR]
[TR]
[TD]5
[/TD]
[TD]I5
[/TD]
[TD]IFC
[/TD]
[/TR]
[TR]
[TD]5
[/TD]
[TD]B3
[/TD]
[TD]Bootleg
[/TD]
[/TR]
[TR]
[TD]5
[/TD]
[TD]D1
[/TD]
[TD]Detail
[/TD]
[/TR]
[TR]
[TD]6
[/TD]
[TD]I6
[/TD]
[TD]IFC
[/TD]
[/TR]
[TR]
[TD]6
[/TD]
[TD]I7
[/TD]
[TD]IFC
[/TD]
[/TR]
[TR]
[TD]6
[/TD]
[TD]R4
[/TD]
[TD]Redline
[/TD]
[/TR]
[TR]
[TD]6
[/TD]
[TD]R5
[/TD]
[TD]Redline
[/TD]
[/TR]
[TR]
[TD]6
[/TD]
[TD]B4
[/TD]
[TD]Bootleg
[/TD]
[/TR]
</tbody>[/TABLE]

To this:
[TABLE="width: 502"]
<tbody>[TR]
[TD]Tag
[/TD]
[TD]IFC
[/TD]
[TD]IFC
[/TD]
[TD]Redline
[/TD]
[TD]Redline
[/TD]
[TD]Bootleg
[/TD]
[TD]Detail
[/TD]
[/TR]
[TR]
[TD]1
[/TD]
[TD]I1
[/TD]
[TD]I2
[/TD]
[TD]R1
[/TD]
[TD][/TD]
[TD]B1
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2
[/TD]
[TD]I3
[/TD]
[TD][/TD]
[TD]R2
[/TD]
[TD][/TD]
[TD]B2
[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]3
[/TD]
[TD]I4
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]4
[/TD]
[TD][/TD]
[TD][/TD]
[TD]R3
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]5
[/TD]
[TD]I5
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD]B3
[/TD]
[TD]D1
[/TD]
[/TR]
[TR]
[TD]6
[/TD]
[TD]I6
[/TD]
[TD]I7
[/TD]
[TD]R4
[/TD]
[TD]R5
[/TD]
[TD]B4
[/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

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
 

Excel Facts

Back into an answer in Excel
Use Data, What-If Analysis, Goal Seek to find the correct input cell value to reach a desired result
Sort by date Sort by votes
Try this for results on sheet2 starting "A1".
Code: 
[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
 
Upvote 0
You must log in or register to reply here.

Similar threads

D
  • Solved
Filter on decremental list
Replies
5
Views
121
Peter_SSs
Peter_SSs
T
  • Question Question
Find highest scorers and return their name
2
Replies
13
Views
252
Peter_SSs
Peter_SSs
GMC The Macro Man
  • Solved
SUM COUNTIFS with AND + OR
Replies
3
Views
194
Fluff
Fluff
I
  • Solved
Formula help - Index, Match, SumProduct/SumIFs? Which one?
Replies
4
Views
158
Eric W
Eric W
C
  • Solved
Countifs Number Of Times Team Play on each weekday
Replies
3
Views
312
CordingBags
C

Forum statistics

Threads
1,224,828
Messages
6,181,204
Members
453,022
Latest member
RobertV1609

Share this page

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top