Vb code To Find the missing triplets and complete the number series..?

Again, will not accept further alteration.
Use it at your own risk.

Sub test()
    Dim a, b(), i As Long, ii As Long, iii As Long, x, y
    Dim AL As Object, temp, e, flg As Boolean, n As Long
    Set AL = CreateObject("System.Collections.ArrayList")
    a = Range("a2", Range("a" & Rows.Count).End(xlUp)).Value
    b = Range("c2", Range("c" & Rows.Count).End(xlUp)).Value
    For i = 1 To UBound(b, 1)
        ReDim temp(1 To 12)
        x = Split(b(i, 1))
        AL.Clear
        For Each e In x
            AL.Add e
        Next
        For ii = 1 To UBound(a, 1)
            y = Split(a(ii, 1))
            For Each e In y
                If AL.Contains(e) Then
                    flg = True
                    Exit For
                End If
            Next
            If Not flg Then
                For Each e In y
                    AL.Add e
                Next
                n = n + 1
                temp(n) = a(ii, 1)
                If n = 12 Then
                    Cells(i + 1, "d").Resize(, 12).Value = temp
                    Exit For
                End If
            End If
            flg = False
        Next
        n = 0
        flg = False
    Next
End Sub

Hi Jindon,
Thanks ever so much for your help but unfortunately the code keep repeating the same triplets
which not what what i need.

That each row contain each of the 39 numbers once,and each row of 8436 of column “A” to be use only once too.

See attachment for code result
Thanks again and very sorry for all this.
sem

Hi,
I used Vb code provided by wonderful and genious” Marcol” it looks promising;
But I need your help to change and add some sort of looping or Do until that keeps going until all matches have been made?
And also to remove that “char” bits and instead of one number in each cell I need each triplet in cells if possible,like in my first post attachment.Because every time you run the code it gives the same result eventhough not correct one.

Option Explicit
Sub GradeFromAtoWhat()
    Dim RowNo As Long
    
    Do While Left(WorksheetFunction.Trim(Cells(RowNo + 1, 1)), InStr(1, WorksheetFunction.Trim(Cells(RowNo + 1, 1)), " ")) * 1 = 1
'        MsgBox WorksheetFunction.Trim(Cells(RowNo + 1, 1))
'        MsgBox InStr(1, WorksheetFunction.Trim(Cells(RowNo + 1, 1)), " ")
'        MsgBox Left(WorksheetFunction.Trim(Cells(RowNo + 1, 1)), InStr(1, WorksheetFunction.Trim(Cells(RowNo + 1, 1)), " "))
        RowNo = RowNo + 1
    Loop
    
    GradeAtoWhatever (RowNo + 1)
End Sub
Sub GradeAtoWhatever(strFinalLetter As String)
    Dim arrTemp As Variant, arrBoolean As Variant
    Dim LastRow As Long, RowNo As Long, LastCol As Long, ColNo As Long, IndexNo As Long
    On Error GoTo ResetApplication
    Application.ScreenUpdating = False
    
    MsgBox strFinalLetter
    strFinalLetter = UCase(strFinalLetter)
    For IndexNo = 3 To (Asc(strFinalLetter) - 2)
        Cells(1, IndexNo) = Chr(IndexNo + 2)
    Next
    ReDim arrBoolean(Asc(strFinalLetter) - 1)
    
    LastRow = Range("A" & Rows.Count).End(xlUp).Row
    For RowNo = 1 To LastRow
        arrTemp = Split(WorksheetFunction.Trim(Range("A" & RowNo)))
        For IndexNo = 0 To UBound(arrBoolean)
            arrBoolean(IndexNo) = IsNumberInRange(Columns(IndexNo + 3), arrTemp)
        Next
        
        For IndexNo = 0 To UBound(arrBoolean)
            If Not arrBoolean(IndexNo) Then
                AppendToFoundList IndexNo + 3, arrTemp
'                Range("B" & RowNo) = Cells(1, IndexNo + 3)
                Exit For
            End If
        Next
    Next
    
    LastCol = Cells(2, Columns.Count).End(xlToLeft).Column
    RowNo = 0
    For ColNo = 3 To LastCol
        LastRow = Cells(Rows.Count, ColNo).End(xlUp).Row
        If LastRow > RowNo Then RowNo = LastRow
    Next
    Range(Cells(1, 3), Cells(1, LastCol)).Clear
    Range(Cells(2, 3), Cells(RowNo, LastCol)).Copy
    Cells(2, LastCol + 2).PasteSpecial Paste:=xlPasteAll, Operation:=xlNone, _
                             SkipBlanks:=False, Transpose:=True
    Application.CutCopyMode = False
    Range(Columns(3), Columns(LastCol)).EntireColumn.Delete
    Range(Columns(3), Columns(ActiveSheet.UsedRange.Columns.Count)).ColumnWidth = 4
    Cells(1, 1).Select
    
ResetApplication:
    Err.Clear
    On Error GoTo 0
    Application.ScreenUpdating = True
End Sub
Sub AppendToFoundList(ColNo As Long, arrApend As Variant)
    Dim NextRow As Long, EndRow As Long
    
    NextRow = Cells(Rows.Count, ColNo).End(xlUp).Row + 1
    EndRow = NextRow + UBound(arrApend)
    Range(Cells(NextRow, ColNo), Cells(EndRow, ColNo)).Value = WorksheetFunction.Transpose(arrApend)
    
    Range(Cells(1, ColNo), Cells(EndRow, ColNo)).RemoveDuplicates Columns:=1, Header:=xlYes
    
End Sub
Function IsNumberInRange(rng As Range, ArrNos As Variant) As Boolean
    Dim n As Long
    Dim rngCheck As Range
    
    IsNumberInRange = False
    For n = 0 To UBound(ArrNos)
        Set rngCheck = rng.Find(ArrNos(n) * 1, , , xlWhole)
        If Not rngCheck Is Nothing Then
            IsNumberInRange = True
            Exit For
        End If
    Next
    
End Function

Here is the result in the attachment
Thanks again for any help or suggestions.
Sem
.