VBA to transpose and delete data

[jmazorra]

Hello folks:

I have recently been given a report and data layout is basically unusable. Here is the current output:

[TABLE="width: 332"]
<tbody>[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Last Name:[/TD]
[TD]Smith[/TD]
[/TR]
[TR]
[TD]First Name:[/TD]
[TD]Jonathan[/TD]
[/TR]
[TR]
[TD]Card Number:[/TD]
[TD]1132[/TD]
[/TR]
[TR]
[TD]Employee Ref:[/TD]
[TD]111222333[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Last Name:[/TD]
[TD] Brown[/TD]
[/TR]
[TR]
[TD]First Name:[/TD]
[TD]John[/TD]
[/TR]
[TR]
[TD]Card Number:[/TD]
[TD]2233[/TD]
[/TR]
[TR]
[TD]Employee Ref:[/TD]
[TD]333444111[/TD]
[/TR]
</tbody>[/TABLE]

I want my data to display:

[TABLE="width: 345"]
<tbody>[TR]
[TD]Name:[/TD]
[TD]First Name:[/TD]
[TD]Card Number:[/TD]
[TD]Employee Ref:[/TD]
[/TR]
[TR]
[TD]Smith[/TD]
[TD]Jonathan[/TD]
[TD]1132[/TD]
[TD]111222333[/TD]
[/TR]
[TR]
[TD]Brown[/TD]
[TD]John[/TD]
[TD]2233[/TD]
[TD]333444111[/TD]
[/TR]
</tbody>[/TABLE]

I can do a copy/paste and transpose but I have 2500 lines of data. Any this can be done via VBA?

 

[MickG]

Try this for results on sheet2.

[COLOR="Navy"]Sub[/COLOR] MG25Oct33
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range, Dn [COLOR="Navy"]As[/COLOR] Range, c [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Application.ScreenUpdating = False
[COLOR="Navy"]Set[/COLOR] Rng = Range("B:B").SpecialCells(xlCellTypeConstants)
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Areas
  [COLOR="Navy"]With[/COLOR] Sheets("Sheet2")
        [COLOR="Navy"]If[/COLOR] Dn.Address = Rng.Areas(1).Address [COLOR="Navy"]Then[/COLOR]
            c = c + 2
            .Cells(c - 1, 1).Resize(, Dn.Count) = Application.Transpose(Dn.Offset(, -1).Value)
            .Cells(c, 1).Resize(, Dn.Count) = Application.Transpose(Dn.Value)
        [COLOR="Navy"]Else[/COLOR]
            c = c + 1
            .Cells(c, 1).Resize(, Dn.Count) = Application.Transpose(Dn.Value)
        [COLOR="Navy"]End[/COLOR] If
 [COLOR="Navy"]End[/COLOR] With
[COLOR="Navy"]Next[/COLOR] Dn
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[jmazorra]

Thank you, it worked like a charm

 

[MickG]

You're welcome