Moving data from rows to columns, depending on unique content in a field in a column

I have what I hope is a simple problem, but I have no idea how to do this, and I'm hoping someone here can help.

I have a worksheet which contains 4 columns.

Name, Company, Sponsor, Email address

The Sponsor and Email address are the same for each unique Company (ie, the Email address and Sponsor is associated with the Company not the Name), but there are up to 12 different Names associated with each unique Company.

In another sheet, what I need to do is create an individual row for each unique company, and then columns to contain the Email address, Sponsor (remember these are the same for each company), and columns to store each individual name that's associated with that company. The maximum amount of names for each Company is 12.

Example Columns for output:

Company, Sponsor, Email Address, Name 1, Name 2, Name 3, Name 4 (etc)

I'm going to have to repeat this process on different sets of data, so I'm looking for an automated process but have no idea where to start.


Vishesh's picture

Visit url:


Thanks for that, Vishesh.

Since I have to do this particular process quite often on different sets of data over the course of time, I really was looking for a macro so it wouldn't be so labor intensive to make it work. However, the solution you came up with involving all that manipulation with formulas and filters, etc, can work until I can find some help creating a macro to do it automatically.

Thank you again!

Why not use Pivot Tables ?

Why not use Pivot Tables ?

Vishesh's picture

Here is code...paste it in a

Here is code...paste it in a general module and run...

Sub ProcessData()
Dim rngOrg As Range
Dim rngTarget As Range
Dim rngTargetData As Range
Dim rngEachOrgRow As Range
Dim rngEachTgtRow As Range

'----Change the source and target range accordingly----------
Set rngOrg = Sheet2.Range("A2:D8")
Set rngTarget = Sheet2.Range("B13")
Call GetUnique(Intersect(rngOrg, rngOrg.Offset(, 1)), rngTarget)

For Each rngEachTgtRow In rngTarget.CurrentRegion.Rows
For Each rngEachOrgRow In rngOrg.Rows
If rngEachOrgRow.Cells(, 2).Value = rngEachTgtRow.Cells(, 1).Value And _
rngEachOrgRow.Cells(, 3).Value = rngEachTgtRow.Cells(, 2).Value And _
rngEachOrgRow.Cells(, 4).Value = rngEachTgtRow.Cells(, 3).Value Then
rngEachTgtRow.Cells(, 1).End(xlToRight).Offset(, 1).Value = rngEachOrgRow.Cells(, 1).Value
End If
Next rngEachOrgRow
Next rngEachTgtRow

Set rngOrg = Nothing
Set rngTarget = Nothing
Set rngTargetData = Nothing
Set rngEachOrgRow = Nothing
Set rngEachTgtRow = Nothing
End Sub

Sub GetUnique(rngSrc As Range, rngTarget As Range)
rngSrc.AdvancedFilter Action:=xlFilterCopy, CopyToRange:=rngTarget, Unique:=True
End Sub


This is terrific. I can't thank you enough. This macro is going to get a ton of use :)