Excel Macro to Transpose the Data

[Sivas]

Hi, Can anyone help on the below macro code.

I have the data like below,

Name	ABC
Model	DEF
City	GHI
Place	JKL
KM
Condition	MNO
1st Owner
2nd Owner	PQR
3rd Owner
Price	STU
Delivered	11111111
Name	XYZ
Model	DJFHA
City	SAHJA
Place	SHJ
KM
Condition	SAFH
1st Owner
2nd Owner	SAHJA
3rd Owner	FGH
Price	DJFHA
Delivered	11111111

<tbody>
</tbody>

and the result should come as below,

Name	Model	City	Place	KM	Condition	1st Owner	2nd Owner	3rd Owner	Price	Delivered
ABC	DEF	GHI	JKL	20	MNO		PQR		STU	11111111
XYZ	DJFHA	SAHJA	SHJ	5	SAFH		SAHJA	FGH	DJFHA	11111111

<tbody>
</tbody>

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