Consolidation

[DanniiMarie]

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:

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

<tbody>
</tbody>

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!

 

[DanniiMarie]

Re: Consolidateion

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

 

[Trebor76]

Re: Consolidateion

Hi DanniiMarie,

Welcome to MrExcel!!

This macro will do the job:

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

 

[DanniiMarie]

Re: Consolidateion

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

 

[Fluff]

Re: Consolidateion

Here's another option, that will sort the employee's

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