Single Column into Multiple in Excel?

Question

I have a long list of contact details that are organised into blocks over 2 columns like this:

A       B
Name    John
Country USA
Phone   1234
Email   j@hotmail.com

Name    John
Country USA
Phone   1234

Name    John
Country USA

I want to organise them instead like this:

Name Country Phone Email
John USA     1234  j@hotmail.com
John USA     1234  
John USA

If the blocks were all the same length (ie all had 4 rows) this would be easy using filters to select by col1 name and copy to the new columns however you'll notice that sometimes email, phone, etc is missing so total block length for each contact is not the same so they will not be aligned after filtering into the new columns.

One way would be transpose each block using "Name" as the start and end point of what should be transposed for each block however I'm not sure how. Maybe there's a simpler way?

How could I best approach this?

Answer 1

Option Explicit

Sub transpose()

    'This code assumes "Name", "Country", "Email" and "Phone" are spelled the same for each 'block', case not important

    Dim wks As Worksheet
    Dim i As Integer
    Dim lastRow As Integer
    Dim outRowCounter As Integer
    Dim heading As String

    Set wks = Worksheets("Sheet1")

    lastRow = wks.Range("A65536").End(xlUp).Row
    outRowCounter = 1

    'assumes the output colums are Name = 5, Country = 6, Phone = 7, Email = 8
    For i = 1 To lastRow

        If LCase(wks.Cells(i, 1).Value) = "name" Then
            outRowCounter = outRowCounter + 1
            wks.Cells(outRowCounter, 5).Value = wks.Cells(i, 2).Value
        ElseIf wks.Cells(i, 1).Value <> "" Then
            heading = wks.Cells(i, 1).Value
            Select Case LCase(heading)
                Case "country"
                    wks.Cells(outRowCounter, 6).Value = wks.Cells(i, 2).Value
                Case "phone"
                    wks.Cells(outRowCounter, 7).Value = wks.Cells(i, 2).Value
                Case "email"
                    wks.Cells(outRowCounter, 8).Value = wks.Cells(i, 2).Value
            End Select
        End If
    Next i

    'clean up
    Set wks = Nothing
End Sub

Answer 2

I would suggest defining a Class whose properties are the different variables you are trying to "map": eg Name, Country, Phone, Email. Then you iterate through the list and add each Class to a collection; then output the collection to some range.

Doing it this way has some advantages in not only making the code easier to read and debug, but it would also allow adding additional properties in the future should that become necessary.

Note that the data is first read into a VBA array; processed; the results placed into another VBA array and then written to the worksheet. This method is usually 5-10x faster than repeatedly accessing the worksheet for each cell's data.

The assumption in the code is that every "block" begins with "Name" in column A.

First insert this Class Module and rename it cPeople

---

Option Explicit
Private pName As String
Private pCountry As String
Private pPhone As String
Private pEmail As String

Public Property Get Name() As String
    Name = pName
End Property
Public Property Let Name(Value As String)
    pName = Value
End Property

Public Property Get Country() As String
    Country = pCountry
End Property
Public Property Let Country(Value As String)
    pCountry = Value
End Property

Public Property Get Phone() As String
    Phone = pPhone
End Property
Public Property Let Phone(Value As String)
    pPhone = Value
End Property

Public Property Get Email() As String
    Email = pEmail
End Property
Public Property Let Email(Value As String)
    pEmail = Value
End Property

---

Then, insert this regular module:

---

Option Explicit
Sub ReOrderList()
    Dim wsRaw As Worksheet, vRaw As Variant
    Dim wsRes As Worksheet, rRes As Range, vRes() As Variant
    Dim cP As cPeople, colP As Collection
    Dim I As Long

'Results go here
Set wsRes = Worksheets("Sheet2")
Set rRes = wsRes.Range("E1")

'Get Raw Data
Set wsRaw = Worksheets("sheet2")
With wsRaw
    vRaw = .Range("A1", .Cells(.Rows.Count, "A").End(xlUp)).Resize(columnsize:=2)
End With

'collect the People objects
Set colP = New Collection
For I = 1 To UBound(vRaw)
    If vRaw(I, 1) = "Name" Then
        Set cP = New cPeople
        With cP
            .Name = vRaw(I, 2)
            Do Until I = UBound(vRaw, 1)
                I = I + 1
                Select Case vRaw(I, 1)
                    Case "Name"
                        colP.Add cP
                        I = I - 1
                        Exit Do
                    Case "Country"
                        .Country = vRaw(I, 2)
                    Case "Phone"
                        .Phone = vRaw(I, 2)
                    Case "Email"
                        .Email = vRaw(I, 2)
                End Select
            Loop
        End With
    End If
Next I
colP.Add cP

'Set up results array
ReDim vRes(0 To colP.Count, 1 To 4)

'Column Headers
vRes(0, 1) = "Name"
vRes(0, 2) = "Country"
vRes(0, 3) = "Phone"
vRes(0, 4) = "Email"

For I = 1 To UBound(vRes, 1)
    With colP(I)
        vRes(I, 1) = .Name
        vRes(I, 2) = .Country
        vRes(I, 3) = .Phone
        vRes(I, 4) = .Email
    End With
Next I

Set rRes = rRes.Resize(UBound(vRes, 1) + 1, UBound(vRes, 2))
Application.ScreenUpdating = False
With rRes
    .EntireColumn.Clear
    .Value = vRes
    .EntireColumn.AutoFit
End With
Application.ScreenUpdating = True

End Sub

---

Change the Worksheet names for the raw data, and the results, as well as the results range (upper left corner cell) as needed for your actual project. I happened to use Sheet2 with the raw data in columns A:B and the results going in E:H. Enjoy.