VBA Script Help

[BBellers]

Hi - I need help perfecting my VBA Script for a fairly simple macro.

I have duplicated names in column A, with unique values in column H. I would like to concatenate the values in column H, if column A is the same. And then delete duplicated rows, but have the coordinating concatenate value stay with the respected row.

What I have so far will concatenate the values, but lists them back to back in column I, making it difficult to then delete the duplicate rows. I have attached an image of what this script creates.


Sub ConcatenateCellsIfSameValueExists()
DestRowRef = 2
CheckedCell = Cells(2, "A").Value
For I = 2 To Range("A" & Rows.Count).End(xlUp).Row + 1
If Cells(I, "A").Value <> CheckedCell Then
tempConValues = CheckedCell & " " & tempConValues
Cells(DestRowRef, "I").Value = tempConValues
tempConValues = ""
DestRowRef = DestRowRef + 1
End If
tempConValues = tempConValues & ", " & Cells(I, "H").Value
CheckedCell = Cells(I, "A").Value
Next
End Sub

 

[Fluff]

Hi & welcome to MrExcel.
How about

Sub BBellers()
   Dim Cl As Range
   
   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.Row
            Cl.Offset(, 8).Value = Cl.Value & ", " & Cl.Offset(, 7).Value
         Else
            Cells(.Item(Cl.Value), 9).Value = Cells(.Item(Cl.Value), 9).Value & ", " & Cl.Offset(, 7).Value
         End If
      Next Cl
   End With
End Sub

 

[BBellers]

Awesome! ok that worked... but now I realized I need to concatenate for column F instead of H... and is there a way to delete the duplicated row after placing the concatenate value into the row?

 

[Fluff]

Ok, how about

Sub BBellers()
   Dim Cl As Range
   
   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.Row
            Cl.Offset(, 8).Value = Cl.Value & ", " & Cl.Offset(, 5).Value
         Else
            Cells(.Item(Cl.Value), 9).Value = Cells(.Item(Cl.Value), 9).Value & ", " & Cl.Offset(, 5).Value
         End If
      Next Cl
   End With
   Range("I2:I" & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlBlanks).EntireRow.Delete
End Sub

 

[BBellers]

Ok, how about

Sub BBellers()
   Dim Cl As Range
  
   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.Row
            Cl.Offset(, 8).Value = Cl.Value & ", " & Cl.Offset(, 5).Value
         Else
            Cells(.Item(Cl.Value), 9).Value = Cells(.Item(Cl.Value), 9).Value & ", " & Cl.Offset(, 5).Value
         End If
      Next Cl
   End With
   Range("I2:I" & Range("A" & Rows.Count).End(xlUp).Row).SpecialCells(xlBlanks).EntireRow.Delete
End Sub

Yesss Beautiful. Thank you!!

 

[Fluff]

You're welcome & thanks for the feedback.