Consolidation

DanniiMarie

New Member
Joined
May 21, 2018
Messages
30
Office Version
  1. 365
  2. 2021
  3. 2019
  4. 2016
  5. 2013
  6. 2011
  7. 2010
  8. 2007
  9. 2003 or older
Platform
  1. Windows
  2. MacOS
  3. Mobile
  4. Web
I have a list of employees and their manager's names. I need to consolidate the list so each manager name appears only once in column A and each employee is in a column to the right of the manager name. Ideally, the employees' names would be alphabetized from left to right, as well.

Here is a sample raw data set:

Manager Name
Employee Name
Cort Haslock
April MacGeffen
Augusto Lampett
Averill Colbran
Leta Bilson
Betteanne Christescu
Benni Lait
Bonnee Plaunch
Leta Bilson
Catarina Francescozzi
Cort Haslock
Clive Corain
Leta Bilson
Dory Fayne
Joana Imeson
Josy Jereatt
Cort Haslock
Marcelo Dumsday
Joana Imeson
Nance Broadbury
Leta Bilson
Quint Minette
Benni Lait
Rosabel Bourdis
Leta Bilson
Stefania Shute
Moll Branscombe
Tine Cardello
Cort Haslock
Trueman Poolton
Joana Imeson
Vanny Jell
Moll Branscombe
Zarla Melmore

<tbody>
</tbody>

Here is what I'd like the final data set to look like:
[TABLE="class: grid, width: 500"]
<tbody>[TR]
[TD]Manager Name[/TD]
[TD]Employee1[/TD]
[TD]Employee2[/TD]
[TD]Employee3[/TD]
[TD]Employee4[/TD]
[TD]Employee5[/TD]
[/TR]
[TR]
[TD]Benni Lait[/TD]
[TD][TABLE="width: 141"]
<tbody>[TR]
[TD="class: xl65, width: 141"]Bonnee Plaunch[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][TABLE="width: 140"]
<tbody>[TR]
[TD="class: xl65, width: 140"]Rosabel Bourdis[/TD]
[/TR]
</tbody>[/TABLE]
[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]
Leta Bilson

<tbody>
</tbody>
[/TD]
[TD]
Betteanne Christescu

<tbody>
</tbody>
[/TD]
[TD]Catarina Francescozzi[/TD]
[TD]Dory Fayne[/TD]
[TD]Quint Minette[/TD]
[TD]Stefania Shute[/TD]
[/TR]
[TR]
[TD]
Joana Imeson

<tbody>
</tbody>
[/TD]
[TD]Josy Jereatt[/TD]
[TD]
Nance Broadbury

<tbody>
</tbody>
[/TD]
[TD]Vanny Jell[/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Augusto Lampett[/TD]
[TD]Averill Colbran[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Cort Haslock[/TD]
[TD]April MacGeffen[/TD]
[TD]Clive Corain[/TD]
[TD]Marcelo Dumsday[/TD]
[TD]Trueman Poolton[/TD]
[TD][/TD]
[/TR]
[TR]
[TD]Moll Branscombe[/TD]
[TD]Tine Cardello[/TD]
[TD]Zarla Melmore[/TD]
[TD][/TD]
[TD][/TD]
[TD][/TD]
[/TR]
</tbody>[/TABLE]

I get a different data set like this each week and I'd like a less manual method to accomplish this task than what I've been using. Thanks!
 

Excel Facts

Spell Check in Excel
Press F7 to start spell check in Excel. Be careful, by default, Excel does not check Capitalized Werds (whoops)
Re: Consolidateion

**Disregard the extra boxes around the two names. That's just a cut and paste issue! LOL! Thanks again!
 
Upvote 0
Re: Consolidateion

Hi DanniiMarie,

Welcome to MrExcel!!

This macro will do the job:

Code:
Option Explicit
Sub Macro1()

    Dim lngLastRow As Long
    Dim lngPasteRow As Long
    Dim lngOffsetCol As Long
    Dim lngMyRow As Long
    Dim rngMyCell As Range
    Dim objMyUniqueData As Object
    
    Application.ScreenUpdating = False
    
    lngLastRow = Range("A:B").Find("*", SearchOrder:=xlByRows, SearchDirection:=xlPrevious).Row 'Assumes names are in column A and B. Change to suit.
    
    Set objMyUniqueData = CreateObject("Scripting.Dictionary")
    
    'List out each unique manager's name and their associated employees
    For Each rngMyCell In Range("A2:A" & lngLastRow) 'Assumes Manager's names are in column A from row 2. Change to suit if necessary.
        If Len(rngMyCell) > 0 Then
            If objMyUniqueData.Exists(CStr(rngMyCell)) = False Then
                objMyUniqueData.Add CStr(rngMyCell), rngMyCell
                If lngPasteRow = 0 Then
                    lngPasteRow = 2
                Else
                    lngPasteRow = lngPasteRow + 1
                End If
                lngOffsetCol = 0
                Range("C" & lngPasteRow).Offset(0, lngOffsetCol) = rngMyCell 'Output unique Manager's name into column C. Change to suit if necessary.
                For lngMyRow = 2 To lngLastRow
                    If Range("A" & lngMyRow) = rngMyCell Then
                        lngOffsetCol = lngOffsetCol + 1
                        Range("C" & lngPasteRow).Offset(0, lngOffsetCol) = Range("B" & lngMyRow)
                    End If
                Next lngMyRow
            End If
        End If
    Next rngMyCell
    
    Set objMyUniqueData = Nothing
    
    Application.ScreenUpdating = True
    
End Sub

Regards,

Robert
 
Upvote 0
Re: Consolidateion

This macro did everything but alphabetize the employees left to right. Even without the alphabetizing, this is a HUGE help!!!!
 
Upvote 0
Re: Consolidateion

Here's another option, that will sort the employee's
Code:
Sub getEmps()
   Dim cl As Range
   Dim Dic As Object
   Dim v1 As String, v2 As String
   Dim Ky As Variant, k As Variant
   Dim Lst As Object, itm As Variant
   Dim c As Long
   
   Set Lst = CreateObject("System.Collections.ArrayList")
   Set Dic = CreateObject("scripting.dictionary")
   For Each cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
      v1 = cl.value: v2 = cl.Offset(, 1).value
      If Not Dic.exists(v1) Then
         Dic.Add v1, CreateObject("scripting.dictionary")
         Dic(v1).Add v2, Nothing
      ElseIf Not Dic(v1).exists(v2) Then
         Dic(v1).Add v2, Nothing
      End If
   Next cl
   For Each Ky In Dic.keys
      For Each k In Dic(Ky).keys
         Lst.Add k
      Next k
      Lst.Sort
      With Sheets("New").Range("A" & Rows.Count).End(xlUp)
         .Offset(1).value = Ky
         .Offset(1, 1).Resize(, Lst.Count).value = Lst.toarray
         Lst.Clear
      End With
   Next Ky
End Sub
 
Upvote 0

Forum statistics

Threads
1,223,164
Messages
6,170,444
Members
452,326
Latest member
johnshaji

We've detected that you are using an adblocker.

We have a great community of people providing Excel help here, but the hosting costs are enormous. You can help keep this site running by allowing ads on MrExcel.com.
Allow Ads at MrExcel

Which adblocker are you using?

Disable AdBlock

Follow these easy steps to disable AdBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the icon in the browser’s toolbar.
2)Click on the "Pause on this site" option.
Go back

Disable AdBlock Plus

Follow these easy steps to disable AdBlock Plus

1)Click on the icon in the browser’s toolbar.
2)Click on the toggle to disable it for "mrexcel.com".
Go back

Disable uBlock Origin

Follow these easy steps to disable uBlock Origin

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back

Disable uBlock

Follow these easy steps to disable uBlock

1)Click on the icon in the browser’s toolbar.
2)Click on the "Power" button.
3)Click on the "Refresh" button.
Go back
Back
Top