remove duplicates and transpose columns to rows

[tommy1234]

Hello
i have an excel table with many projects for each employee.
the name of the employee and the project can return many times (the table is sorted), but there are duplicates
i need to create a new table with those fields :
1. column "A" will contain the employee name
2. column "B" will contain all the project codes (field unique value) in the same row divided by space
3. column "C" will contain all the project names in the same row divided by space.

thank you

[GTO]

i need to create a new table with those fields :
1. column "A" will contain the employee name
2. column "B" will contain all the project codes (field unique value) in the same row divided by space
3. column "C" will contain all the project names in the same row divided by space.

Greetings,

Please show what the 'After' should look like in the workbook, and what the logic is.

Mark

[tommy1234]

Hi
i added an excel file with 2 worksheets :
Before - the source table
After - the result table

thanks

[GTO]

Greetings Tommy,

Not well tested, in a junk copy of your wb, try:

In a Standard Module:


Option Explicit

Sub exa()
Dim _
DIC As Object, _
wksSource As Worksheet, _
wksDest As Worksheet, _
aryInput As Variant, _
aryOutput As Variant, _
vntEmpName As Variant, _
i As Long, _
ii As Long

Const WS_SOURCE_NAME As String = "Before"

With ThisWorkbook
Set wksSource = .Worksheets(WS_SOURCE_NAME)
Set wksDest = .Worksheets.Add(After:=.Worksheets(WS_SOURCE_NAME), _
Type:=xlWorksheet)
End With

Set DIC = CreateObject("Scripting.Dictionary")

With wksSource
aryInput = .Range(.Range("A2"), .Cells(.Rows.Count, "A").End(xlUp)).Value

For Each vntEmpName In aryInput
DIC.Item(vntEmpName) = Empty
Next

aryOutput = Application.Transpose(DIC.Keys)
ReDim Preserve aryOutput(1 To UBound(aryOutput, 1), 1 To 3)

aryInput = .Range(.Range("A1"), _
.Cells(.Rows.Count, "A").End(xlUp)).Resize(, 3).Value

For i = 1 To UBound(aryOutput, 1)
For ii = 1 To UBound(aryInput, 1)
If aryOutput(i, 1) = aryInput(ii, 1) Then
If InStr(1, aryOutput(i, 2), aryInput(ii, 2)) = 0 Then
aryOutput(i, 2) = aryOutput(i, 2) & aryInput(ii, 2) & Chr(32)
aryOutput(i, 3) = aryOutput(i, 3) & aryInput(ii, 3) & Chr(32)
End If
End If
Next
Next

For i = 1 To UBound(aryOutput, 1)
aryOutput(i, 2) = Trim(aryOutput(i, 2))
aryOutput(i, 3) = Trim(aryOutput(i, 3))
Next
End With

wksDest.Range("A2").Resize(UBound(aryOutput, 1), 3).Value = aryOutput

With wksDest.Range("A2").Resize(UBound(aryOutput, 1), 3).Offset(-1) _
.Resize(wksDest.Range("A2").Resize(UBound(aryOutput, 1), 3) _
.Rows.Count + 1)

.Rows(1).Value = Array("Employee name", "Project Code", "Project Name")
.Rows(1).Font.Bold = True
.HorizontalAlignment = xlCenter
.Borders.LineStyle = xlContinuous
.EntireColumn.AutoFit
End With
End Sub

Hope that helps,

Mark