Excel Macro to Transpose the Data

[Sivas]

Hi, Can anyone help on the below macro code.

I have the data like below,

[TABLE="width: 175"]
<tbody>[TR]
[TD]Name[/TD]
[TD]ABC[/TD]
[/TR]
[TR]
[TD]Model[/TD]
[TD]DEF[/TD]
[/TR]
[TR]
[TD]City[/TD]
[TD]GHI[/TD]
[/TR]
[TR]
[TD]Place[/TD]
[TD]JKL[/TD]
[/TR]
[TR]
[TD]KM[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Condition[/TD]
[TD]MNO[/TD]
[/TR]
[TR]
[TD]1st Owner[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2nd Owner[/TD]
[TD]PQR[/TD]
[/TR]
[TR]
[TD]3rd Owner[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Price[/TD]
[TD]STU[/TD]
[/TR]
[TR]
[TD]Delivered[/TD]
[TD]11111111[/TD]
[/TR]
[TR]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Name[/TD]
[TD]XYZ[/TD]
[/TR]
[TR]
[TD]Model[/TD]
[TD]DJFHA[/TD]
[/TR]
[TR]
[TD]City[/TD]
[TD]SAHJA[/TD]
[/TR]
[TR]
[TD]Place[/TD]
[TD]SHJ[/TD]
[/TR]
[TR]
[TD]KM[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Condition[/TD]
[TD]SAFH[/TD]
[/TR]
[TR]
[TD]1st Owner[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]2nd Owner[/TD]
[TD]SAHJA[/TD]
[/TR]
[TR]
[TD]3rd Owner[/TD]
[TD]FGH[/TD]
[/TR]
[TR]
[TD]Price[/TD]
[TD]DJFHA[/TD]
[/TR]
[TR]
[TD]Delivered[/TD]
[TD]11111111[/TD]
[/TR]
</tbody>[/TABLE]

and the result should come as below,

[TABLE="width: 790"]
<tbody>[TR]
[TD]Name[/TD]
[TD]Model[/TD]
[TD]City[/TD]
[TD]Place[/TD]
[TD]KM[/TD]
[TD]Condition[/TD]
[TD]1st Owner[/TD]
[TD]2nd Owner[/TD]
[TD]3rd Owner[/TD]
[TD]Price[/TD]
[TD]Delivered[/TD]
[/TR]
[TR]
[TD]ABC[/TD]
[TD]DEF[/TD]
[TD]GHI[/TD]
[TD]JKL[/TD]
[TD="align: right"]20[/TD]
[TD]MNO[/TD]
[TD][/TD]
[TD]PQR[/TD]
[TD][/TD]
[TD]STU[/TD]
[TD="align: right"]11111111[/TD]
[/TR]
[TR]
[TD]XYZ[/TD]
[TD]DJFHA[/TD]
[TD]SAHJA[/TD]
[TD]SHJ[/TD]
[TD="align: right"]5[/TD]
[TD]SAFH[/TD]
[TD][/TD]
[TD]SAHJA[/TD]
[TD]FGH[/TD]
[TD]DJFHA[/TD]
[TD="align: right"]11111111
[/TD]
[/TR]
</tbody>[/TABLE]

I wrote a code as,

Sub Macro3()
'
' Macro3 Macro
' extraction
'
' Keyboard Shortcut: Ctrl+i
'
Range("B1:B11").Select
Selection.Copy
ActiveSheet.Next.Select
Range("A1").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True
ActiveSheet.Previous.Select
Range("B13:B23").Select
Application.CutCopyMode = False
Selection.Copy
ActiveSheet.Next.Select
Range("A2").Select
Selection.PasteSpecial Paste:=xlPasteValues, Operation:=xlNone, SkipBlanks _
:=False, Transpose:=True

It is taking only the particular range, but i have N number of data and it will get added more in future.

Can anyone help on this.

Thanks.

 

[MickG]

Try this for results starting "D1".

[COLOR="Navy"]Sub[/COLOR] MG27Feb04
[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]
[COLOR="Navy"]Set[/COLOR] Rng = Range("A:A").SpecialCells(xlCellTypeConstants)
c = 1
[COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Areas
    c = c + 1
    [COLOR="Navy"]If[/COLOR] c = 2 [COLOR="Navy"]Then[/COLOR]
        Range("D1").Resize(, Dn.Count).Value = Application.Transpose(Dn.Value)
    [COLOR="Navy"]End[/COLOR] If
        Range("D" & c).Resize(, Dn.Count).Value = Application.Transpose(Dn.Offset(, 1).Value)
[COLOR="Navy"]Next[/COLOR] Dn
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[Sivas]

Thank you so much for your help Mick.

A small request. The report is generating in same sheet but I need the report in next sheet.

Can you please help.

 

[footoo]

Putting results on next sheet :

Sub v()
Dim lr&, r&
lr = Cells(Rows.Count, "B").End(xlUp).Row
For r = 1 To lr Step 12
    Sheets(ActiveSheet.Index + 1).Cells(Rows.Count, "A").End(xlUp)(2).Resize(, 11) = _
        Application.Transpose(Cells(r, "B").Resize(11).Value)
Next
End Sub

 

[Sivas]

Thank you for your help.

The report is not getting generated properly, as per your code.

Can you please help me in getting it resolved

 

[footoo]

In what way is it not producing what you need?
Are there always 11 rows in each data set with an empty row between each set?

If MickG's code does what you need try :

Sub MG27Feb04()
Dim Rng As range, Dn As range, c As Long
Set Rng = range("A:A").SpecialCells(xlCellTypeConstants)
c = 1
For Each Dn In Rng.Areas
    c = c + 1
    If c = 2 Then
        Sheets(ActiveSheet.Index + 1).range("A1").Resize(, Dn.Count).Value = Application.Transpose(Dn.Value)
    End If
        Sheets(ActiveSheet.Index + 1).range("A" & c).Resize(, Dn.Count).Value = Application.Transpose(Dn.Offset(, 1).Value)
Next Dn
End Sub