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

What does custom number format of ;;; mean?
Three semi-colons will hide the value in the cell. Although most people use white font instead.
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

GMC The Macro Man
  • Solved
SUM COUNTIFS with AND + OR
Replies
3
Views
143
Fluff
Fluff
I
  • Solved
Formula help - Index, Match, SumProduct/SumIFs? Which one?
Replies
4
Views
141
Eric W
Eric W
C
  • Solved
Countifs Number Of Times Team Play on each weekday
Replies
3
Views
291
CordingBags
C
A
  • Question Question
Daily Interest Loan Scheduler | Missed Payments
Replies
0
Views
231
aurelius33
A
C
  • Solved
VBA Code to move Amount Due from individual sheets to a master sheet, and then copy information from the master sheet back to the individual sheets?
Replies
7
Views
387
Coyotex3
C

Forum statistics

Threads
1,223,908
Messages
6,175,307
Members
452,633
Latest member
DougMo

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