Error message on Macro

[ariel20029]

Hi,
I found this Macro to concatenate information base on the same project number and combine the different rows that contain the different roles per project. I am getting an error message Type Missmatch. xRes(I + 1, 2) = xRes(I + 1, 2) & ", " & xSrc(J, 2)Can anyone help? Thanks,Sharon

Data sample
Column A Column B
Project ID Role
PS1 CONS
PS1 PM
PS2 SR CONS
PS2 PM
PS3 PM


The result would be in Column S
PS1- CONS, PM
PS2-SR CONS, PM
PS3 - PM


Sub ConcatenateCellsIfSameValues()
Dim xCol As New Collection
Dim xSrc As Variant
Dim xRes() As Variant
Dim I As Long
Dim J As Long
Dim xRg As Range
xSrc = Range("A1", Cells(Rows.Count, "A").End(xlUp)).Resize(, 2)
Set xRg = Range("S1")
On Error Resume Next
For I = 2 To UBound(xSrc)
xCol.Add xSrc(I, 1), TypeName(xSrc(I, 1)) & CStr(xSrc(I, 1))
Next I
On Error GoTo 0
ReDim xRes(1 To xCol.Count + 1, 1 To 2)
xRes(1, 1) = "WBSE"
xRes(1, 2) = "Combined Role"
For I = 1 To xCol.Count
xRes(I + 1, 1) = xCol(I)
For J = 2 To UBound(xSrc)
If xSrc(J, 1) = xRes(I + 1, 1) Then
xRes(I + 1, 2) = xRes(I + 1, 2) & ", " & xSrc(J, 2)
End If
Next J
xRes(I + 1, 2) = Mid(xRes(I + 1, 2), 2)
Next I
Set xRg = xRg.Resize(UBound(xRes, 1), UBound(xRes, 2))
xRg.NumberFormat = "@"
xRg = xRes
xRg.EntireColumn.AutoFit
End Sub

 

[Dryver14]

should this Dim xSrc As Variant be Dim xSrc() as variant ?

 

[Fluff]

Try

Sub ConcatOnUnique()

   Dim Cl As Range
   Dim Ky As Variant
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Cl.Offset(, 1).Value
         Else
            .Item(Cl.Value) = .Item(Cl.Value) & ", " & Cl.Offset(, 1).Value
         End If
      Next Cl
      For Each Ky In .keys
         Range("S" & Rows.Count).End(xlUp).Offset(1).Value = Ky & " - " & .Item(Ky)
      Next Ky
   End With
End Sub

 

[Norie]

Sharon

Do you have any error values on the worksheet?

What are the values of xRes(I + 1, 2), xRes(I + 1, 2) and xSrc(J, 2) when you get the error?

 

[ariel20029]

Try

Sub ConcatOnUnique()

   Dim Cl As Range
   Dim Ky As Variant
   
   With CreateObject("scripting.dictionary")
      For Each Cl In Range("A2", Range("A" & Rows.Count).End(xlUp))
         If Not .exists(Cl.Value) Then
            .Add Cl.Value, Cl.Offset(, 1).Value
         Else
            .Item(Cl.Value) = .Item(Cl.Value) & ", " & Cl.Offset(, 1).Value
         End If
      Next Cl
      For Each Ky In .keys
         Range("S" & Rows.Count).End(xlUp).Offset(1).Value = Ky & " - " & .Item(Ky)
      Next Ky
   End With
End Sub

thank you so much this worked Perfectly!!!!!! thanks for your help sorry for the delay in responding!!!!
Sharon

 

[Fluff]

Gad we could help & thanks for the feedback