Complicated Cut/Paste Macro with Transpose and variable amounts of data

[samst]

Hi All

I was wondering if anyone has an idea of how to accomplish the following:

In column A I have an ID# that sometimes repeats. In columns B-D there is corresponding data. For each time that the ID# in column a repeats I would like the data in Columns B-D to be cut to the first row that the ID number appears in the first blank column.

So for example:
This
ColA ColB ColC ColD ColE ColF
123 ABC DEF GHI JKL MNO
123 abc def ghi jkl mno
234 PQR STU VWX YZa bcd
456 efg hij jkl mno pqr
456 stu vwx yz! @#$ %^&
456 &*( )_+ ABC DEF GHI

Would change to this
ColA ColB ColC ColD ColE ColF ColG ColH ColI ColJ ColK ColL ColM ColN ColO ColP
123 ABC DEF GHI JKL MNO abc def ghi jkl mno
234 PQR STU VWX YZa bcd
456 efg hij jkl mno pqr stu vwx yz! @#$ %^& &*( )_+ ABC DEF GHI

Any help would be greatly appreciated.

Thanks!

 

[MickG]

Try this:-

[COLOR="Navy"]Sub[/COLOR] MG16Jul28
[COLOR="Navy"]Dim[/COLOR] Rng         [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn          [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] nRng        [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Q
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("A2"), Range("A" & Rows.count).End(xlUp))
    [COLOR="Navy"]With[/COLOR] CreateObject("scripting.dictionary")
        .CompareMode = vbTextCompare
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng
    [COLOR="Navy"]If[/COLOR] Not .Exists(Dn.Value) [COLOR="Navy"]Then[/COLOR]
        .Add Dn.Value, Array(Dn, 6)
    [COLOR="Navy"]Else[/COLOR]
        Q = .Item(Dn.Value)
            Q(0).Offset(, Q(1)).Resize(, 5).Value = Dn.Offset(, 1).Resize(, 5).Value
            Q(1) = Q(1) + 5
            [COLOR="Navy"]If[/COLOR] nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR]
                [COLOR="Navy"]Set[/COLOR] nRng = Dn
            [COLOR="Navy"]Else[/COLOR]
                [COLOR="Navy"]Set[/COLOR] nRng = Union(nRng, Dn)
            [COLOR="Navy"]End[/COLOR] If
                .Item(Dn.Value) = Q
    [COLOR="Navy"]End[/COLOR] If
[COLOR="Navy"]Next[/COLOR]
    [COLOR="Navy"]If[/COLOR] Not nRng [COLOR="Navy"]Is[/COLOR] Nothing [COLOR="Navy"]Then[/COLOR] nRng.EntireRow.Delete
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]With[/COLOR]
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[samst]

Thanks! Looks like this will work for me You're awesome.

 

[MickG]

Thanks for the feedback
Mick