Complex Combinatorial sort VBA/Macro

Maybe :

Sub Test()
  Dim a, b, i As Long, j As Long, v, z As New Collection
  With Sheets("List1")
    With .Range("B3:F" & .Cells(.Rows.Count, "B").End(xlUp).Row)
      a = .Value
      ReDim b(1 To UBound(a, 1), 1 To 1)
      For i = 1 To UBound(a, 1)
          For j = 2 To 4
              On Error Resume Next
                 z.Add key:=a(i, j), Item:=Empty
              On Error GoTo 0
          Next j
      Next i
      For i = 1 To UBound(a, 1)
          On Error Resume Next
             For j = 2 To 4
                 v = z(a(i, j))
             Next j
             If Err.Number = 0 Then
                b(i, 1) = a(i, 5)
                For j = 2 To 4
                    z.Remove a(i, j)
                Next j
             End If
          On Error GoTo 0
      Next i
      'Put Result on column I
      With .Offset(, 7).Resize(, 1)
        .Value = b
        .Offset(-1).Cells(1, 1).Value = Application.Sum(b)
      End With
    End With
  End With
End Sub

I would love to have a macro which will be able to sort all combinations (from 1 to 197) in 197! (factorial) ways.

1. If the universe were a simple cube 40 billion light years on a side, and a quark was a cube 10^-18 m on a side, how many quarks would it take to pack the universe solid?

2. How does that number compare in size to 197!

Don't lose the hope yet, you have so many constraints, that there must be no duplicate item on columns C-D-E, this will reduce the combinations a lot.
Running this code for 1 minute will produce all the 184556 combinations that meet your criteria (no dupes on C-D-E) :

Sub Test2()
  Debug.Print vbCrLf & "Start at : " & Format$(Now, "HH:MM:SS")

  Dim cell As Range, a, b, f As Boolean, i As Long, u As Long, z As New Collection
  With Sheets("List1")
    a = .Range("B3:F" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
    Set cell = .Range("J3")
  End With
  u = UBound(a, 1)
  For i = 1 To u
      z.Add Array(i, a(i, 1), "-" & a(i, 2) & "-" & a(i, 3) & "-" & a(i, 4) & "-", a(i, 5))
  Next i
  While z.Count
    b = z(1)
    z.Remove 1
    f = False
    For i = b(0) + 1 To u
        If (InStrB(1, b(2), "-" & a(i, 2) & "-", vbBinaryCompare) + InStrB(1, b(2), "-" & a(i, 3) & "-", vbBinaryCompare) + InStrB(1, b(2), "-" & a(i, 4) & "-", vbBinaryCompare)) = 0 Then
           z.Add Array(i, b(1) & "-" & a(i, 1), b(2) & (a(i, 2) & "-" & a(i, 3) & "-" & a(i, 4) & "-"), b(3) + a(i, 5))
           f = True
        End If
    Next i
    If f = False Then
       cell.Resize(, 3).Value = Array(b(1), Mid$(b(2), 2, Len(b(2)) - 2), b(3))
       Set cell = cell.Offset(1)
    End If
  Wend

  Debug.Print "Stop at  : " & Format$(Now, "HH:MM:SS")
End Sub

Try this .It works. This code gives Value 1 to all rows In G column with highest sum after trying all combinations with your conditions.
code

Sub Macro1()

Dim SumNum As Long, SumMax As Long, TA As Long, TB As Long, TC As Long
Dim LR As Long
Dim Ro(1 To 193) As Long

LR = Range("B" & Rows.Count).End(xlUp).Row
Range("G3:G" & LR) = 0

For TA = 3 To LR
Set Ary = CreateObject("System.collections.Arraylist")
X = 1

 For L = 0 To 2
 Ary.Add Range("C" & TA).Offset(0, L).Value
 Next L
 SumNum = Range("F" & TA)
 Ro(X) = TA
    
    For TB = TA + 1 To LR
        For M = 0 To 2
        If Ary.contains(Range("C" & TB).Offset(0, M).Value) Then GoTo Line1
        Next M
    
        If M = 3 Then
        Ary.Add Range("C" & TB).Value
        Ary.Add Range("D" & TB).Value
        Ary.Add Range("E" & TB).Value
        X = X + 1
        Ro(X) = TB
        SumNum = SumNum + Range("F" & TB)
        End If
Line1:
    Next TB
    
If SumNum > SumMax Then
Range("G3:G" & LR) = 0
SumMax = SumNum
SumNum = 0

For TC = 1 To X
Range("G" & Ro(TC)) = 1
Next TC

End If

Next TA

End Sub

Rule 08: Cross-posting Without Telling Us

Your post does not comply with Rule 8 of our Forum RULES. Do not cross-post your question on multiple forums without telling us about your threads on other forums.

Post a link to any other forums where you have asked the same question. If you have fewer than 10 posts here, you will not be able to post a link, but you must still tell us where else you have asked the question.

Cross-posting is when you post the same question in other forums on the web. The last thing you want to do is waste people's time working on an issue you have already resolved elsewhere. We prefer that you not cross-post at all, but if you do (and it's unlikely to go unnoticed), you MUST provide a link (copy the url from the address bar in your browser) to the cross-post.

Expect cross-posted questions without a link to be closed and a message will be posted by the moderator explaining why. We are here to help so help us to help you!

Read this to understand why we ask you to do this, and then please edit your first post to include links to any and all cross-posts in any other forums (not just this site).

No further help to be offered, please, until the OP has complied with this request.

You are out of luck this time

Just trying a very small portion of data (a small slice of both arrays), it's already run out of system resources (result is much more than Excel rows, out of memory, take "forever" time, etc).

The code below just to show that this code works, but it will never complete if you do the whole data.

The code only process 2 rows of left array :
a = .Range("B3:D4").Value
while it should be (if you want to process the whole left array) :
a = .Range("B3:D" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value

and it only process 105 rows of right array :
a = .Range("H3:K107").Value
while it should be (if you want to process the whole right array) :
a = .Range("H3:K" & .Cells(.Rows.Count, "H").End(xlUp).Row).Value

Just doing these slices, it already took 2 minutes and produce 622788 rows result

Sub Test3()
  Debug.Print vbCrLf & "Start at : " & Format$(Now, "HH:MM:SS")

  Dim cell As Range, a, b, c, f As Boolean, i As Long, u As Long, z As New Collection
  With Sheets("List1")
    Set cell = .Range("O3")
    'a = .Range("B3:D" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
    a = .Range("B3:D4").Value
    For i = 1 To UBound(a, 1)
        z.Add Array(0, a(i, 1), "-" & a(i, 2) & "-", a(i, 3))
    Next i
    'a = .Range("H3:K" & .Cells(.Rows.Count, "H").End(xlUp).Row).Value
    a = .Range("H3:K107").Value
    u = UBound(a, 1)
  End With
  While z.Count
    b = z(1)
    z.Remove 1
    f = False
    For i = b(0) + 1 To u
        If (InStrB(1, b(2), "-" & a(i, 2) & "-", vbBinaryCompare) + InStrB(1, b(2), "-" & a(i, 3) & "-", vbBinaryCompare) + InStrB(1, b(2), "-" & a(i, 4) & "-", vbBinaryCompare)) = 0 Then
           z.Add Array(i, b(1) & "-" & a(i, 1), b(2) & (a(i, 2) & "-" & a(i, 3) & "-"), b(3) + a(i, 4))
           f = True
        End If
    Next i
    If f = False Then
       cell.Resize(, 3).Value = Array(b(1), Mid$(b(2), 2, Len(b(2)) - 2), b(3))
       Set cell = cell.Offset(1)
    End If
  Wend

  Debug.Print "Stop at  : " & Format$(Now, "HH:MM:SS")
End Sub

Again, this will be the same problem as post #12 (I highlight the lines where the code working with slice of array vs whole array), but here is the code :

Sub Test3()
  Debug.Print vbCrLf & "Start at : " & Format$(Now, "HH:MM:SS")

  Dim cell As Range, a, b, f As Boolean, i As Long, u As Long, z As New Collection, y As New Collection
  With Sheets("List1")
    'a = .Range("B3:E" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
    a = .Range("B3:E22").Value
    Set cell = .Range("J3")
  End With
  u = UBound(a, 1)
  For i = 1 To u
      z.Add Array(i, a(i, 1), "-" & a(i, 2) & "-" & a(i, 3) & "-", a(i, 4))
  Next i
  While z.Count
    b = z(1)
    z.Remove 1
    f = False
    For i = b(0) + 1 To u
        If (InStrB(1, b(2), "-" & a(i, 2) & "-", vbBinaryCompare) + InStrB(1, b(2), "-" & a(i, 3) & "-", vbBinaryCompare)) = 0 Then
           z.Add Array(i, b(1) & "-" & a(i, 1), b(2) & (a(i, 2) & "-" & a(i, 3) & "-"), b(3) + a(i, 4))
           f = True
        End If
    Next i
    If f = False Then
       cell.Resize(, 3).Value = Array(b(1), Mid$(b(2), 2, Len(b(2)) - 2), b(3))
       Set cell = cell.Offset(1)
    End If
  Wend

  Debug.Print "Stop at  : " & Format$(Now, "HH:MM:SS")
End Sub

Maybe :

Sub Test()
  Dim cell As Range, a, b, c, i As Long, j As Long, k As Long, isFound As Boolean, s1 As String, s2 As String
  With Sheets("List1")
    Set cell = .Range("M3")
    'a = .Range("A1").CurrentRegion.Value
    a = .Range("B1").CurrentRegion.Resize(7).Value
    'b = .Range("H1").CurrentRegion.Value
    b = .Range("H1").CurrentRegion.Resize(50).Value
    For i = 3 To UBound(a, 1)
        s1 = "-" & a(i, 2) & "-"
        c = Split(a(i, 1), "-")
        For j = 0 To UBound(c)
            c(j) = "A" & c(j)
        Next j
        s2 = Join(c, "-")
        For j = 3 To UBound(b, 1)
            c = Split(b(j, 2), "-")
            isFound = False
            For k = 0 To UBound(c)
                If InStrB(1, s1, "-" & c(k) & "-", vbBinaryCompare) Then
                   isFound = True
                   Exit For
                End If
            Next k
            If Not isFound Then
               c = Split(b(j, 1), "-")
               For k = 0 To UBound(c)
                   c(k) = "B" & c(k)
               Next k
               cell.Resize(, 3).Value = Array(s2 & "-" & Join(c, "-"), a(i, 2) & "/" & b(j, 2), a(i, 3) + b(j, 3))
               Set cell = cell.Offset(1)
            End If
        Next j
    Next i
  End With
End Sub

Modified code on Post #6 :

Sub Test2()
  Debug.Print vbCrLf & "Start at : " & Format$(Now, "HH:MM:SS")

  Const uLimit = 25000
  Dim cell As Range, a, b, f As Boolean, i As Long, t, u As Long, z As New Collection
  With Sheets("List1")
    a = .Range("B3:F" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
    Set cell = .Range("J3")
  End With
  u = UBound(a, 1)
  For i = 1 To u
      z.Add Array(i, a(i, 1), "-" & a(i, 2) & "-" & a(i, 3) & "-" & a(i, 4) & "-", a(i, 5))
  Next i
  While z.Count
    b = z(1)
    z.Remove 1
    f = False
    For i = b(0) + 1 To u
        If (InStrB(1, b(2), "-" & a(i, 2) & "-", vbBinaryCompare) + InStrB(1, b(2), "-" & a(i, 3) & "-", vbBinaryCompare) + InStrB(1, b(2), "-" & a(i, 4) & "-", 

vbBinaryCompare)) = 0 Then
           t = b(3) + a(i, 5)
           z.Add Array(i, b(1) & "-" & a(i, 1), b(2) & (a(i, 2) & "-" & a(i, 3) & "-" & a(i, 4) & "-"), t)
           f = True
           If t >= uLimit Then Exit For
        End If
    Next i
    If f = False Then
       cell.Resize(, 3).Value = Array(b(1), Mid$(b(2), 2, Len(b(2)) - 2), b(3))
       Set cell = cell.Offset(1)
    End If
  Wend

  Debug.Print "Stop at  : " & Format$(Now, "HH:MM:SS")
End Sub

Modified code on Post #12 :

Sub Test3()
  Debug.Print vbCrLf & "Start at : " & Format$(Now, "HH:MM:SS")

  Dim cell As Range, a, b, c, f As Boolean, i As Long, t, u As Long, z As New Collection
  With Sheets("List1")
    Set cell = .Range("O3")
    'a = .Range("B3:D" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
    a = .Range("B3:D4").Value
    For i = 1 To UBound(a, 1)
        z.Add Array(0, a(i, 1), "-" & a(i, 2) & "-", a(i, 3))
    Next i
    'a = .Range("H3:K" & .Cells(.Rows.Count, "H").End(xlUp).Row).Value
    a = .Range("H3:K107").Value
    u = UBound(a, 1)
  End With
  While z.Count
    b = z(1)
    z.Remove 1
    f = False
    For i = b(0) + 1 To u
        If (InStrB(1, b(2), "-" & a(i, 2) & "-", vbBinaryCompare) + InStrB(1, b(2), "-" & a(i, 3) & "-", vbBinaryCompare) + InStrB(1, b(2), "-" & a(i, 4) & "-", 

vbBinaryCompare)) = 0 Then
           t = b(3) + a(i, 4)
           z.Add Array(i, b(1) & "-" & a(i, 1), b(2) & (a(i, 2) & "-" & a(i, 3) & "-"), t))
           f = True
           If t >= uLimit Then Exit For
        End If
    Next i
    If f = False Then
       cell.Resize(, 3).Value = Array(b(1), Mid$(b(2), 2, Len(b(2)) - 2), b(3))
       Set cell = cell.Offset(1)
    End If
  Wend

  Debug.Print "Stop at  : " & Format$(Now, "HH:MM:SS")
End Sub

Modified code on Post #14 :

Sub Test3()
  Debug.Print vbCrLf & "Start at : " & Format$(Now, "HH:MM:SS")

  Const uLimit = 25000
  Dim cell As Range, a, b, f As Boolean, i As Long, t, u As Long, z As New Collection
  With Sheets("List1")
    'a = .Range("B3:E" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
    a = .Range("B3:E22").Value
    Set cell = .Range("J3")
  End With
  u = UBound(a, 1)
  For i = 1 To u
      z.Add Array(i, a(i, 1), "-" & a(i, 2) & "-" & a(i, 3) & "-", a(i, 4))
  Next i
  While z.Count
    b = z(1)
    z.Remove 1
    f = False
    For i = b(0) + 1 To u
        If (InStrB(1, b(2), "-" & a(i, 2) & "-", vbBinaryCompare) + InStrB(1, b(2), "-" & a(i, 3) & "-", vbBinaryCompare)) = 0 Then
           t = b(3) + a(i, 4)
           z.Add Array(i, b(1) & "-" & a(i, 1), b(2) & (a(i, 2) & "-" & a(i, 3) & "-"), t)
           f = True
           If t >= uLimit Then Exit For
        End If
    Next i
    If f = False Then
       cell.Resize(, 3).Value = Array(b(1), Mid$(b(2), 2, Len(b(2)) - 2), b(3))
       Set cell = cell.Offset(1)
    End If
  Wend

  Debug.Print "Stop at  : " & Format$(Now, "HH:MM:SS")
End Sub

Modified code on Post #16 :

Sub Test()
  Const uLimit = 25000
  Dim cell As Range, a, b, c, i As Long, j As Long, k As Long, isFound As Boolean, s1 As String, s2 As String, t
  With Sheets("List1")
    Set cell = .Range("M3")
    'a = .Range("A1").CurrentRegion.Value
    a = .Range("B1").CurrentRegion.Resize(20).Value
    b = .Range("H1").CurrentRegion.Value
    'b = .Range("H1").CurrentRegion.Resize(50).Value
    For i = 3 To UBound(a, 1)
        s1 = "-" & a(i, 2) & "-"
        c = Split(a(i, 1), "-")
        For j = 0 To UBound(c)
            c(j) = "A" & c(j)
        Next j
        s2 = Join(c, "-")
        For j = 3 To UBound(b, 1)
            c = Split(b(j, 2), "-")
            isFound = False
            For k = 0 To UBound(c)
                If InStrB(1, s1, "-" & c(k) & "-", vbBinaryCompare) Then
                   isFound = True
                   Exit For
                End If
            Next k
            If Not isFound Then
               t = a(i, 3) + b(j, 3)
               c = Split(b(j, 1), "-")
               For k = 0 To UBound(c)
                   c(k) = "B" & c(k)
               Next k
               cell.Resize(, 3).Value = Array(s2 & "-" & Join(c, "-"), a(i, 2) & "/" & b(j, 2), t)
               Set cell = cell.Offset(1)
               If t >= uLimit Then Exit For
            End If
        Next j
    Next i
  End With
End Sub

No, it is cut a branch of combinations as soon as combining one item with other items after it, has reach total income 25000 (assuming the data are sorted descending from big to small), this way you can reduce a lot of unnecessary combinations.

If you still want to keep calculating all combinations, but only don't display (put the result on Excel sheet) for value less then 45000, the time won't changed too much. The slowness is come from iterating a very much of combinations (as you said : factorial), not from displaying to screen.

In that case, you need to wrap two lines at the end of sub, with an IF..ENDIF block (shown with blue lines).
I'll show you for the code on post #6, you can do the rest by yourself.

Sub Test2c()
  Debug.Print vbCrLf & "Start at : " & Format$(Now, "HH:MM:SS")

  Dim cell As Range, a, b, f As Boolean, i As Long, u As Long, z As New Collection, y As New Collection
  With Sheets("List1")
    a = .Range("B3:F" & .Cells(.Rows.Count, "B").End(xlUp).Row).Value
    Set cell = .Range("J3")
  End With
  u = UBound(a, 1)
  For i = 1 To u
      z.Add Array(i, a(i, 1), "-" & a(i, 2) & "-" & a(i, 3) & "-" & a(i, 4) & "-", a(i, 5))
  Next i
  While z.Count
    b = z(1)
    z.Remove 1
    f = False
    For i = b(0) + 1 To u
        If (InStrB(1, b(2), "-" & a(i, 2) & "-", vbBinaryCompare) + InStrB(1, b(2), "-" & a(i, 3) & "-", vbBinaryCompare) + InStrB(1, b(2), "-" & a(i, 4) & "-", vbBinaryCompare)) = 0 Then
           z.Add Array(i, b(1) & "-" & a(i, 1), b(2) & (a(i, 2) & "-" & a(i, 3) & "-" & a(i, 4) & "-"), b(3) + a(i, 5))
           f = True
        End If
    Next i
    If f = False Then
       If b(3) > 45000 Then
          cell.Resize(, 3).Value = Array(b(1), Mid$(b(2), 2, Len(b(2)) - 2), b(3))
          Set cell = cell.Offset(1)
       End If
    End If
  Wend

  Debug.Print "Stop at  : " & Format$(Now, "HH:MM:SS")
End Sub

Note : although you now have enough rows to display the result, it is not guaranteed that there is no other error such as memory (RAM) is enough to finish the job.