Calcolo combinatorio - Ricerca, cancella ambi ,terni,quaterne, ripetute o uguali

Sub Elimina()
Dim cmb() As String, elim()
Range("H:L").ClearContents
urC = Cells(Rows.Count, 3).End(xlUp).Row
urD = Cells(Rows.Count, 4).End(xlUp).Row
urE = Cells(Rows.Count, 5).End(xlUp).Row
urF = Cells(Rows.Count, 6).End(xlUp).Row
'quaterna
ReDim cmb(1 To urF)
For i = 1 To urF
    cmb(i) = Cells(i, 3) & "," & Cells(i, 4) & "," & Cells(i, 5) & "," & Cells(i, 6)
Next i
fino = urF: num = 3: mx = 4: cln = 8: a = 1
GoSub ciclo
'terno
ReDim cmb(urE - urF)
b = 1
For i = urF + 1 To urE
    cmb(b) = Cells(i, 3) & "," & Cells(i, 4) & "," & Cells(i, 5)
    b = b + 1
Next i
fino = urE - urF: num = 2: mx = 3: 'cln = 10
GoSub ciclo
'ambo
ReDim cmb(1 To urD - urE + 1)
b = 1
For i = urE + 1 To urD
    cmb(b) = Cells(i, 3) & "," & Cells(i, 4)
    b = b + 1
Next i
fino = urD - urE: num = 1: mx = 2: 'cln = 12
GoSub ciclo
a = 1
For i = urC To 1 Step -1
    For w = 3 To 6
        If Cells(i, w) <> "" Then nr = nr & Cells(i, w) & ","
    Next w
    nr = Left(nr, Len(nr) - 1)
    For j = 1 To UBound(elim)
        If nr = elim(j) Then
            Rows(i).EntireRow.Delete (xlUp)
        End If
    Next j
    nr = ""
Next i
Exit Sub
'
ciclo:
For i = 1 To fino
    uno = Split(cmb(i), ",")
    For j = i + 1 To fino
        due = Split(cmb(j), ",")
        For k = 0 To num
            For h = 0 To num
                If uno(k) = due(h) Then pr = pr + 1
                If pr = mx Then
                    ReDim Preserve elim(1 To a)
                    elim(a) = cmb(j)
                    a = a + 1
                End If
            Next h
        Next k
        pr = 0
    Next j
Next i
    Return
End Sub

Sub CombinUguali()
Dim Qix As Object, a, i As Long, r As Long, rs As Long
Set Qix = CreateObject("scripting.dictionary")
Set a = Range("C1").CurrentRegion.Resize(, 4)

For i = 1 To a.Rows.Count
    a.Rows(i).Sort a(i, 1), Header:=xlNo, Orientation:=xlLeftToRight
    Qix(Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Chr(2))) = 1
Next i

a.ClearContents: r = 1
For Each c In Qix.keys
    r = r + 1
    a(r, 1).Resize(, 4) = Split(c, Chr(2))
Next c
MsgBox "Fine elaborazione"
End Sub

Sub CombinUguali3()
Dim a, a1, i As Long, r As Long, mArr As New Collection
Set a = Range("C1").CurrentRegion.Resize(, 4)
r = 1
For i = 1 To a.Rows.Count
    a1 = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Chr(2))
    a.Rows(i).Sort a(i, 1), Header:=xlNo, Orientation:=xlLeftToRight
    b = Join(Array(a(i, 1), a(i, 2), a(i, 3), a(i, 4)), Chr(2))
    On Error Resume Next
    mArr.Add b, b
    If Err = 0 Then
        a(r, 1).Resize(, 4) = Split(a1, Chr(2))
        r = r + 1
    End If
    On Error GoTo 0
Next i
Range("C" & r & ":F" & Rows.Count).ClearContents
MsgBox "Fine elaborazione"
End Sub