Filtering Sheet based on criteria - removing duplicates

I have a problem with a macro I found in the web. I'm fairly new to macro coding and would really appreciate all the help I can get. I was able to run the macro and I just need one more filtering.

Raw data looks like this:
GroupName GroupID SubGroup
Carol 101 Caroline
Carol 101 Caroline
Carol 101 Carl
Greg 102 Greg1
Greg 102 Greg1
Greg 102 Greg 1
Greg 102 Greg

I was able to filter to this:
GroupName GroupID SubGroup
Carol 101 Caroline / Caroline / Carl
Greg 102 Greg1 / Greg1 / Greg 1 / Greg

I would want to filter the SubGroup further to this:
GroupName GroupID SubGroup
Carol 101 Caroline / Carl
Greg 102 Greg1 / Greg 1 / Greg

-removing the duplicates in SubGroup column.

Please Help! Thanks!

Hi

Put this into a general module.

Type mytype
  p1 As String
  p2 As String
  p3 As String
End Type

Sub aaa()
  Dim OutSH As Worksheet
  Dim xx As mytype
  Dim arr() As mytype
  ReDim arr(0)
  Set OutSH = Sheets("Sheet2")
  OutSH.Cells.ClearContents
  Sheets("Sheet 1").Activate
  OutSH.Range("A1:B1").Value = Range("A1:B1").Value
  OutSH.Range("C1").Value = Range("D1").Value
  Range("A:D").AdvancedFilter Action:=xlFilterCopy, copytorange:=OutSH.Range("A1:C1"), unique:=True
  OutSH.Activate
  For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    gg = Cells(i, 1).Value
    gi = Cells(i, 2).Value
    holder = ""
    While Cells(i, 1).Value = gg And Cells(i, 2).Value = gi
      holder = holder & Cells(i, 3).Value & " / "
      i = i + 1
    Wend
    arr(UBound(arr)).p1 = gg
    arr(UBound(arr)).p2 = gi
    arr(UBound(arr)).p3 = Left(holder, Len(holder) - 3)
    ReDim Preserve arr(UBound(arr) + 1)
    
  Next i
  
  Range("A2:C" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
  For i = LBound(arr) To UBound(arr) - 1
    Range("A2").Offset(i, 0).Value = arr(i).p1
    Range("A2").Offset(i, 1).Value = arr(i).p2
    Range("A2").Offset(i, 2).Value = arr(i).p3
  Next i
  
End Sub

Then change your button code to be

Private Sub CommandButton1_Click()
  Call aaa
End Sub

rylo

That's almost it! Except it's also removing data that should stay.

We begin with this data:

Carol 101 Caroline
Carol 101 Carol 1
Carol 101 Carl

Greg 102 Greg1
Greg 102 Greg1
Greg 102 Greg 1
Greg 102 Greg

Tim 103 Tommy
Tim 103 Tommy
Tim 103 Timmy
Tim 103 Timmy
Tim 103 Tommy

rylo's code generated this:

Carol 101 Caroline / Carol 1 / Carl
Greg 102 Greg 1 / Greg
Tim 103 Timmy

For Carol, the result is fine.
For Greg, it should have been Greg1 / Greg 1 / Greg
For Tim, it should have been Tommy / Timmy

Thanks for the quick reply! You the man!
Thanks rylo!

Hi

oops....

Try

Sub aaa()
  Dim OutSH As Worksheet
  Dim xx As mytype
  Dim arr() As mytype
  ReDim arr(0)
  Set OutSH = Sheets("Sheet2")
  OutSH.Cells.ClearContents
  Sheets("Sheet 1").Activate
  OutSH.Range("A1:B1").Value = Range("A1:B1").Value
  OutSH.Range("C1").Value = Range("D1").Value
  Range("A:D").AdvancedFilter Action:=xlFilterCopy, copytorange:=OutSH.Range("A1:C1"), unique:=True
  OutSH.Activate
  For i = 2 To Cells(Rows.Count, 1).End(xlUp).Row
    gg = Cells(i, 1).Value
    gi = Cells(i, 2).Value
    holder = ""
    While Cells(i, 1).Value = gg And Cells(i, 2).Value = gi
      holder = holder & Cells(i, 3).Value & " / "
      i = i + 1
    Wend
    arr(UBound(arr)).p1 = gg
    arr(UBound(arr)).p2 = gi
    arr(UBound(arr)).p3 = Left(holder, Len(holder) - 3)
    ReDim Preserve arr(UBound(arr) + 1)
    i = i - 1
  Next i
  
  Range("A2:C" & Cells(Rows.Count, 1).End(xlUp).Row).ClearContents
  For i = LBound(arr) To UBound(arr) - 1
    Range("A2").Offset(i, 0).Value = arr(i).p1
    Range("A2").Offset(i, 1).Value = arr(i).p2
    Range("A2").Offset(i, 2).Value = arr(i).p3
  Next i
  
End Sub

rylo

You did it! Thanks so much! I'd shake your hands if I could but the best thing I can do is to thank you from the bottom of my heart! That's one wicked talent you got! You the man!