Is a macro ok?
Option Explicit
Sub testme()
Dim CurWks As Worksheet
Dim NewWks As Worksheet
Dim FirstRow As Long
Dim LastRow As Long
Dim iRow As Long
Dim oRow As Long
Dim oCol As Long
Dim res As Variant
Set CurWks = Worksheets("Sheet1")
Set NewWks = Worksheets.Add
With CurWks
FirstRow = 2
LastRow = .Cells(.Rows.Count, "A").End(xlUp).Row
'sort original range by Id, name, period
With .Range("a1:C" & LastRow)
.Sort key1:=.Columns(1), order1:=xlAscending, _
key2:=.Columns(2), order2:=xlAscending, _
header:=xlYes
End With
'Get a list of unique contact types
.Range("b1:b" & LastRow).AdvancedFilter _
action:=xlFilterCopy, unique:=True, copytorange:=NewWks.Range("A1")
End With
With NewWks
With .Range("a:a")
.Sort key1:=.Columns(1), order1:=xlAscending, header:=xlYes
End With
.Range("A2", .Cells(.Rows.Count, "A").End(xlUp)).Copy
.Range("b1").PasteSpecial Transpose:=True
.Columns(1).Clear
.Range("A1").Value = "EE#"
End With
With CurWks
oRow = 1
For iRow = FirstRow To LastRow
If .Cells(iRow, "A").Value <> .Cells(iRow - 1, "A").Value Then
'different EE#
oRow = oRow + 1
'new EE# in column A
NewWks.Cells(oRow, "A").Value = .Cells(iRow, "A").Value
End If
oCol = Application.Match(.Cells(iRow, "B").Value, NewWks.Rows(1), 0)
If IsError(oCol) Then
'this shouldn't happen
MsgBox "Error with row: " & iRow
Exit Sub
Else
NewWks.Cells(oRow, oCol).Value = .Cells(iRow, "C").Value
End If
Next iRow
End With
NewWks.UsedRange.Columns.AutoFit
End Sub
If you're new to macros:
Debra Dalgleish has some notes how to implement macros here:
http://www.contextures.com/xlvba01.html
David McRitchie has an intro to macros:
http://www.mvps.org/dmcritchie/excel/getstarted.htm
Ron de Bruin's intro to macros:
http://www.rondebruin.nl/code.htm
(General, Regular and Standard modules all describe the same thing.)
