Create multiple lists based on main data source

**GhostCookie** · 11-30-2012, 01:56 PM

Hello All,

I have been trying to find an answer for my problem, but I am not sure how to word it. Basically I have a master list of employees, and the jobs they are working. I am trying to take my master list of information, and have it create a list for the jobs and the names of who is working them.

eg.

Column A
Employee 1
Employee 2
Employee 3
Employee 4
Employee 5

Column B
Job Name 1
Job Name 1
Job Name 1
Job Name 2
Job Name 2

Would give me a list that looks like:

Column A
Job Name 1
Employee 1
Employee 2
Employee 3

Column B
Job Name 2
Employee 4
Employee 5

I appreciate any help with this, or with being pointed in the right direction.

Thanks
Dan

**Sean Thomas** · 11-30-2012, 02:32 PM

It might be best to add a workbook with an example of the data in the same format as you have and then on another sheet (or where you want it) show how you would like the information laid out.

This will make it easier to work with.

**GhostCookie** · 11-30-2012, 03:19 PM

Here is a quick example, if a more in depth one is necessary I can post it later, but I will need to scrub out any confidential info.

Basically sheet 1 is what I have, a list of employees and the job they are on for the week, and sheet 2 is how we need to display them, the job on top and then the names of those working the specified jobs.

Thanks for the quick reply

7DAYEXAMPLE.xlsx

**mike7952** · 12-01-2012, 10:24 AM

Give this a try

Option Explicit
Sub abc()
 Const sh1 As String = "sheet1"
 Const sh2 As String = "sheet2"
 Dim a, k, x, i As Long, n As Long
 
 With Worksheets(sh1)
    a = .Range("a1").CurrentRegion
 End With
 
 With CreateObject("scripting.dictionary")
    .comparemode = 1
    For i = 2 To UBound(a)
        If Not .exists(a(i, 2)) Then
            .Item(a(i, 2)) = a(i, 1)
        Else
            .Item(a(i, 2)) = Join(Array(.Item(a(i, 2)), a(i, 1)), "|")
        End If
    Next
    a = .items
    k = .keys
 End With
 With Worksheets(sh2)
    .Cells.Delete
    With .Cells(Rows.Count, 1).End(xlUp)
    For i = 0 To UBound(a)
        x = Application.Transpose(Split(a(i), "|"))
        With .Offset(, n)
            .Value = k(i)
            .Font.Bold = True
        End With
        With .Offset(1, n).Resize(UBound(x))
            .Value = x
            .Columns.EntireColumn.AutoFit
        End With
        n = n + 2
    Next
    End With
 End With
End Sub

**jindon** · 12-01-2012, 12:13 PM

try

Sub test()
    Dim a, i As Long, w, maxRow As Long, e
    a = Sheets("sheet1").Range("a1").CurrentRegion.Value
    With CreateObject("Scripting.Dictionary")
        .CompareMode = 1
        For i = 2 To UBound(a, 1)
            If Not .exists(a(i, 2)) Then
                ReDim w(1 To 1)
                w(1) = a(i, 2)
                .Item(a(i, 2)) = w
                w(1) = Empty
                .Item(i & Chr(2)) = w
            End If
            w = .Item(a(i, 2))
            ReDim Preserve w(1 To UBound(w) + 1)
            w(UBound(w)) = a(i, 1)
            maxRow = Application.Max(maxRow, UBound(w))
            .Item(a(i, 2)) = w
        Next
        For Each e In .keys
            w = .Item(e)
            ReDim Preserve w(1 To maxRow)
            .Item(e) = w
        Next
        Sheets("sheet2").Cells(1).Resize(maxRow, .Count - 1).Value = _
        Application.Transpose(.items)
        Sheets("sheet2").Activate
    End With
End Sub