Transpose data on multiple rows

[ndikum]

I have a spreadsheet which am trying to transpose data into separate columns. See example sheet below:

PolicyNo	Name_Address	Agent No	Code	Premium
11256	James Cook	2WD	PXT	25.50
	Line1
	Line2
	Town
2356	Peter Jones	56TF	TDE	25.50
	Line1
	Line2
	Line3
	Town
3456B	Stella Gold	4TU	2PUT	15.0
	Line1
	Line2
	Line3
	Line4
	Town
3678	John Smith	5XT	PTY	10.5
	Line1
	Line2
	Town

<tbody>
</tbody>

The tast is to convert the "Name_Address" into separate columns - Name,Line1,Line2,Line3,Town respectively and making sure it adhers to the right PolicyNo column.

I will appreciate if anyone can provide help in this area

 

[hiker95]

ndikum,

What version of Excel and Windows are you using?

Thanks for the screenshot of your raw data.

Can you supply an additional screenshot of what the results should look like (manually formatted by you, based on the raw data supplied).

 

[ndikum]

Hi Hiker,

I am using Excel 2013 on a Windows 8 machine. See below the expected final results.

PolicyNo Name_Address Agent No Code Premium

11256 James Cook Line1 Line2 Town 2WD PXT 25.50


2356 Peter Jones Line1 Line2 Line3 Town 56TF TDE 25.50


3456B Stella Gold Line1 Line2 Line3 Line4 Town 4TU 2PUT 15.0


3678 John Smith Line1 Line2 Town 5XT PTY 10.5


I hope this helps.

Thanks,

Terry

 

[nuked]

Here's one way. Add it to a new module, and try on a copy of your data:-

Option Explicit

Sub MrE()

Dim i           As Long
Dim lRow        As Long
Dim ws          As Worksheet
Dim iCount      As Integer
Dim iMaxCount   As Integer
Dim sStr()      As String

Set ws = ActiveSheet

''Get max number of additional columns
    lRow = ws.Range("B" & ws.Rows.count).End(xlUp).Row
        For i = 1 To lRow
            iCount = iCount + Abs(IsEmpty(ws.Cells(i, 1)))
                If Not IsEmpty(ws.Cells(i, 1)) Or (i = lRow) Then
                    iMaxCount = WorksheetFunction.Max(iMaxCount, iCount)
                    iCount = 0
                End If
        Next

''Insert columns
    ws.Range(Cells(1, 3), Cells(ws.Rows.count, 2 + iMaxCount)).Insert xlShiftToRight

''Start transposing
    iCount = 0
    
    For i = 3 To lRow + 1
        If IsEmpty(ws.Cells(i, 1)) And Not i = lRow + 1 Then
            ReDim Preserve sStr(iCount)
            sStr(UBound(sStr)) = ws.Cells(i, 2).Value
            ws.Cells(i, 2).ClearContents
            iCount = iCount + 1
        Else
            ws.Range(Cells(i - (iCount + 1), 3), Cells(i - (iCount + 1), 2 + iCount)) = sStr
            iCount = 0
            ReDim sStr(0)
        End If
    Next i
        ''Delete empty rows
    For i = lRow To 3 Step -1
        If IsEmpty(ws.Cells(i, 2)) Then ws.Cells(i, 2).EntireRow.Delete
    Next i
End Sub

 

[MickG]

Try this:-
NB:- This code will re Arrange your data !!!!!!!!!!

[COLOR="Navy"]Sub[/COLOR] MG31Oct21
[COLOR="Navy"]Dim[/COLOR] Rng [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] Dn [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] A [COLOR="Navy"]As[/COLOR] Range
[COLOR="Navy"]Dim[/COLOR] oMax [COLOR="Navy"]As[/COLOR] [COLOR="Navy"]Long[/COLOR]
Application.ScreenUpdating = False
[COLOR="Navy"]Set[/COLOR] Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp)).Offset(, -1).SpecialCells(xlCellTypeBlanks)
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] A [COLOR="Navy"]In[/COLOR] Rng.Areas
        oMax = Application.Max(oMax, A.Count)
    [COLOR="Navy"]Next[/COLOR] A
        Columns("C:C").Resize(, oMax).Insert
    [COLOR="Navy"]For[/COLOR] [COLOR="Navy"]Each[/COLOR] Dn [COLOR="Navy"]In[/COLOR] Rng.Areas
        Dn.Offset(-1, 2).Resize(1, Dn.Count) = Application.Transpose(Dn.Offset(, 1).Value)
    [COLOR="Navy"]Next[/COLOR] Dn
        Rng.EntireRow.Delete
Application.ScreenUpdating = True
[COLOR="Navy"]End[/COLOR] [COLOR="Navy"]Sub[/COLOR]

Regards Mick

 

[ndikum]

Hello Mick,

This worked like magic.

Thanks ever so much.

Regards,

Terry

PS: I might come back with some more..lol

 

[hiker95]

MickG,

VERY NICE.

The part concerning:
Set Rng = Range(Range("B2"), Range("B" & Rows.Count).End(xlUp)).Offset(, -1).SpecialCells(xlCellTypeBlanks)

One for my archives. I can use this. Thank you very much.


ndikum,

Instead of the output looking like this?

Excel 2007
	A	B	C	D	E	F	G	H	I	J
1	PolicyNo	Name_Address						Agent No	Code	Premium
2	11256	James Cook	Line1	Line2	Town			2WD	PXT	25.5
3	2356	Peter Jones	Line1	Line2	Line3	Town		56TF	TDE	25.5
4	3456B	Stella Gold	Line1	Line2	Line3	Line4	Town	4TU	2PUT	15
5	3678	John Smith	Line1	Line2	Town			5XT	PTY	10.5
6
Sheet1

Maybe, this?

Excel 2007
	A	B	C	D	E	F	G	H	I	J
1	PolicyNo	Name_Address						Agent No	Code	Premium
2	11256	James Cook	Line1	Line2			Town	2WD	PXT	25.5
3	2356	Peter Jones	Line1	Line2	Line3		Town	56TF	TDE	25.5
4	3456B	Stella Gold	Line1	Line2	Line3	Line4	Town	4TU	2PUT	15
5	3678	John Smith	Line1	Line2			Town	5XT	PTY	10.5
6
Sheet1

Can we see what the actual raw data looks like before the macro? I mean, all the Line1's, Line2's, Line3's, Line4's, and Town's?