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

Good evening,
I’m not sure if it possible, if you could provide me with a vb code please, to do this;
I have a list”703 rows” of string numbers” triplet” in column “C”, I need the code to fill columns”D:O”from the list in column”A” to complete the the missing numbers from column “C” so
That each row contain each of the 39 numbers once,and each row of 8436 of column “A” to be use only once too.
I have done example for first row, in the attached file;
Thanks for your patienceand appreciate any help on this.
Sem

Hi Arlu,
thank you for your time,very much appreciated.
Yes all 8436 rows must be used to complete columns "D to O".
column"C" have 703rows x 12 columns"D:O" it will give you a total of 8436 .

If i need 1 particular number to complete the 39 number sequence but its already used in another row, what should i do?

That is why it's very difficult to solve and maybe there are misplaced rows,in short the code have to loop through the 8436 rows to find the missing string to complete the series.
Thanks again and Kind regards.
Sem

Any suggestion please,?
Thank you.
Sem

Bump........?

Thank you Arlu,
Very very much appreciated.

Is this Solveable?
Thanks for any assistance......
Sem

Hi Arlu,
Thanks very much for your time and no harry you can have as much time as you can no problem at all,
even if it takes months.
Thanks again and much obliged.
sem

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
.

maybe so (run-time macro around 9.5 seconds)

Sub ertert()
Dim tm!: tm = Timer
Dim x, y(), i&, j&, k, s, t$, u&, bu As Boolean
x = Range("A1", Cells(Rows.Count, 1).End(xlUp)).Value

With New Dictionary
    .CompareMode = 1
    For i = 1 To UBound(x): .Item(x(i, 1)) = 1: Next i

    x = Range("C1", Cells(Rows.Count, 3).End(xlUp)).Value
    ReDim y(1 To UBound(x), 1 To 12)
    For i = 1 To UBound(x)
        t = x(i, 1)
        For Each k In .Keys
            s = Split(k)
            For j = 0 To UBound(s)
                If InStr(t, s(j)) Then bu = True: Exit For
            Next j
            If bu = False Then
                u = u + 1: y(i, u) = k: t = t & " " & k
                .Remove k
            End If
            bu = False
        Next k
        u = 0
    Next i
    [q2].Resize(.Count).Value = WorksheetFunction.Transpose(.Keys)
End With
[d1:o703].Value = y()
MsgBox Timer - tm
End Sub

Hi Nilem,
Thanks ever so much for your invaluable help, very very much appreciated.
It's almost there..would you kindly add some sort of looping or Do until it get all the results?
and also when i run with my worksheet i got compile error;(User-Defined type not defined)and it highlite
this line

With New Dictionary

thanks again and very much obliged.
Sem

good evening,
i would appreciate if someone can assist to insert loop to the code in post #14
to keep trying untill it find all the correct result.
thanks and kind regards.
sem

Bump.......

Bump............

Hi ,
When i run the code in post #14 to list as in my first post it gives me only 69 result out of 703 rows.but when i randomly sort those list in column “A and C” i get higher numbers of the results “367 out of 703” the highest.so is there any way to make this process done by the code to keep randomise those lists in columns “A and C” until all 703 rows completed or to set a parameter say 500 or 50000 times and after that to give me the highest result from that process.
Thanks
Sem

Bump,,,,,,,,

replace this line

With New Dictionary

with this line

With CreateObject("Scripting.Dictionary")

or would be better if you plug in a reference: TOOLS menu - References - Microsoft Scripting Runtime - Ok.

Hi Nilem,
thank you very much for your time and effort much appreciate.
would you kindly insert a loop so the code keep going until it find all the result like in my attached workbook?
That would be fantastic if you can do it?Think of it as a password .?
Thanks again and very kind regards
Sem

Good evening <
anyone can assist me how to add loop to "Nilem's" code please???
Thanks
sem

I would very much appreciate, for any suggestion ..
Thank you.
sem

Any ideas please?
Thanks
sem

Very sorry for bumping....?

Bump??????

Help Please...?

Bump..........

Good evening Arlu,
thank you very very much for your time and very sorry for keep bumping...Its realy emberassing.
What i need is a loop to be incerted to Nilem's code in post#14. because when ever you run the code its give the same result even though its not the complete result.so if anyone can assist to keep the code looping until it find all "703rows by 13 colums" complete and correct result without duplication.
Thank you again,
Kind regards
sem

Would someone kindly assist me to solve this please?
Thanks
sem

bump,,,,,,,,,

Hi, Sem. Are you sure that your problem has a solution?
I tried to simulate your example with 01, 02, ...09 triples - all the conditions of your problem can not be performed even by hand.
Perhaps I'm wrong.

Good evening Nilem,
Thanks very much for your time ,yes thereis a solution but that code on your post #14 it needs to keep randomise columns "A and C" until it find solution it may take more than 30 min.
here the solution for combin(9,3)=84 which you're trying to solve;

RESULT
01 02 03 04 05 08 06 07 09
01 02 04 03 08 09 05 06 07
01 02 05 03 07 09 04 06 08
01 02 06 03 05 09 04 07 08
01 02 07 03 06 08 04 05 09
01 02 08 03 06 09 04 05 07
01 02 09 03 07 08 04 05 06
01 03 04 02 07 09 05 06 08
01 03 05 02 06 07 04 08 09
01 03 06 02 04 09 05 07 08
01 03 07 02 04 08 05 06 09
01 03 08 02 05 06 04 07 09
01 03 09 02 04 05 06 07 08
01 04 05 02 03 06 07 08 09
01 04 06 02 03 07 05 08 09
01 04 07 02 03 05 06 08 09
01 04 08 02 06 09 03 05 07
01 04 09 02 05 08 03 06 07
01 05 06 02 07 08 03 04 09
01 05 07 02 03 08 04 06 09
01 05 08 02 03 09 04 06 07
01 05 09 02 06 08 03 04 07
01 06 07 02 08 09 03 04 05
01 06 08 02 03 04 05 07 09
01 06 09 02 05 07 03 04 08
01 07 08 02 05 09 03 04 06
01 07 09 02 04 06 03 05 08
01 08 09 02 04 07 03 05 06

Thanks again
sem

Bump.???????

Bump.???????

much appreciate for Any Assistance ?