How to get sets of unique data from a column which contains combined data (names)

Hi Mehdi

Just received  the below idea from an other Microsoft community member Andreas Killer which works.

Many thanks again for assistance and attention.

Kindest regards.

-Split the data into 2 columns so that each cell contains one name, no headers above.
- Open the VBA editor, insert a regular module and paste in the code below.
- Create a button (form control) in the sheet and assign the Main macro from below to the button.
- Select the cell inside the data which should appear as 1st pair in the 1st group.
- Click the button

.................................................
Option Explicit

Sub Main()
  Dim Groups As New Collection
  Dim Group As New Collection
  Dim Used As Object 'Scripting.Dictionary
  Dim Data, Pair
  Dim Count As Long
  Dim i As Long, j As Long, f As Long
 
  'Number of pairs in a group
  Count = 5
  'Create space for a pair
  ReDim Pair(1 To 2)
  'For future use: If your pair has more then 2 people in a row use this instead:
  'ReDim Pair(1 To UBound(Data, 2))
 
  'Get the data and start position
  With ActiveCell
    Data = .CurrentRegion.Value
    f = .Row
  End With
  'Be sure we have enough data
  If Not IsArray(Data) Then
    MsgBox "Select a cell inside the data an try again"
    Exit Sub
  End If
  If UBound(Data, 2) < 2 Then
    MsgBox "Data must have at min. 2 columns"
    Exit Sub
  End If
 
  'Prepare our variables
  Set Used = CreateObject("Scripting.Dictionary")
  Used.CompareMode = vbTextCompare
 
  'Step 1: Analyse the data
 
  'Initial position
  i = f
  Do
    'Get a pair from this row
    For j = 1 To UBound(Pair)
      Pair(j) = Data(i, j)
      'One of them already used?
      If Used.Exists(Pair(j)) Then GoTo NextRow
    Next
   
    'Add to current group
    Group.Add Pair
    For j = 1 To UBound(Pair)
      Used.Add Pair(j), 0
    Next
   
    'Full?
    If Group.Count = Count Then
      'Store
      Groups.Add Group
      Set Group = New Collection
    End If

NextRow:
    i = i + 1
    If i > UBound(Data) Then i = 1
  Loop Until i = f
  'Store last group if contain members
  If Group.Count > 0 Then Groups.Add Group
 
  'Step 2: Output
 
  'Prepare
  ReDim Data(1 To Groups.Count * Count, 1 To UBound(Pair) + 1)
  'Compile the data
  i = 0
  f = 0
  For Each Group In Groups
    f = f + 1 'Group number
    For Each Pair In Group
      i = i + 1
      For j = 1 To UBound(Pair)
        Data(i, j) = Pair(j)
      Next
      Data(i, j) = f
    Next
  Next
 
  'Create a new sheet and write the data into
  Dim Ws As Worksheet
  Set Ws = Sheets.Add(After:=ActiveSheet)
  With Ws
    With .Range("A1:C1")
      .Value = Array("Name A", "Name B", "Group")
      .Font.Bold = True
    End With
    With .Range("A2").Resize(UBound(Data), UBound(Data, 2))
      .Value = Data
      .EntireColumn.AutoFit
    End With
  End With
End Sub