VBA Excel - How to delete duplicate combinations - vba

Question

I wrote a code to write all the possible combinations with 3 numbers using a list of numbers.
Dim min, max, mppt1, mppt2, mppt3, reference As Integer
'seting the range of numbers
min = Range("AA3").Value
max = Range("AB3").Value
For mppt1 = min To max
For mppt2 = min To max
For mppt3 = min To max
Range("AA" & reference).Value = mppt1
Range("AB" & reference).Value = mppt2
Range("AC" & reference).Value = mppt3
referencia = reference + 1
Next mppt3
Next mppt2
Next mppt1
This works fine. But then, i need to delete all duplicate combinations (independent of the order)
For example, if i have this combinations:
16 | 17 | 18
16 | 18 | 17
18 | 17 | 17
18 | 16 | 16
After the delete, i should have this output:
16 | 17 | 18
18 | 17 | 17
18 | 16 | 16
How can i put this logic in my code?

Answer 1

Rather than getting rid of the duplicates, why not avoid avoid outputting them to start off with?
Instead of your second and third loops starting from min, have them start from the previous loop variable. Here's a similar working example I mocked up:
Sub Test()
Dim min As Integer, max As Integer
Dim i As Integer, j As Integer, k As Integer
min = 16
max = 18
For i = min To max
For j = i To max
For k = j To max
Debug.Print i, j, k
Next k
Next j
Next i
End Sub
this prints the following into the immediate window:
16 16 16
16 16 17
16 16 18
16 17 17
16 17 18
16 18 18
17 17 17
17 17 18
17 18 18
18 18 18

Answer 2

Try the code below. I added some code to add up the 3 cells and put the answer in column 5. Then I sort by column 5. The next loop uses the totals and deletes any total that is a duplicate each time the total changes.......
Dim min, max, mppt1, mppt2, mppt3, reference As Integer
'seting the range of numbers
min = Range("f1").Value
max = Range("g1").Value
reference = 1
For mppt1 = min To max
For mppt2 = min To max
For mppt3 = min To max
Range("A" & reference).Value = mppt1
Range("B" & reference).Value = mppt2
Range("C" & reference).Value = mppt3
reference = reference + 1
Next mppt3
Next mppt2
Next mppt1
Dim r As Integer
Range("A1:E1").Select
Range(Selection, Selection.End(xlDown)).Select
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Clear
ActiveWorkbook.Worksheets("Sheet1").Sort.SortFields.Add Key:=Range("a1:a27") _
, SortOn:=xlSortOnValues, Order:=xlAscending, DataOption:=xlSortNormal
With ActiveWorkbook.Worksheets("Sheet1").Sort
.SetRange Range("A1:E27")
.Header = xlGuess
.MatchCase = False
.Orientation = xlTopToBottom
.SortMethod = xlPinYin
.Apply
End With
Dim Col1 As Integer
Dim Col2 As Integer
Dim Col3 As Integer
Col1 = Cells(1, 1)
Col2 = Cells(1, 2)
Col3 = Cells(1, 3)
r = 2
Do Until Len(Trim(Cells(r, 1))) = 0
DoEvents
startrow = r
Col1 = Cells(r, 1)
Col2 = Cells(r, 2)
Col3 = Cells(r, 3)
r = r + 1
Do While Cells(r, 1) = Col1
DoEvents
If Cells(r, 2) = Col2 And Cells(r, 3) = Col3 Then
Cells(r, 1).EntireRow.Delete
Else
If Cells(r, 2) = Col3 And Cells(r, 3) = Col2 Then
Cells(r, 1).EntireRow.Delete
Else
r = r + 1
End If
End If
Loop
r = startrow + 1
Loop
Cells(1, 5).EntireColumn.ClearContents

Answer 3

Use a dictionary to collect the unique sums as keys and the individual values as an array item then write the arrays back to the worksheet.
Option Explicit
Sub saqwjh()
Dim d As Long, k As Variant, dict As Object
Set dict = CreateObject("scripting.dictionary")
With Worksheets("sheet1")
For d = 1 To .Cells(.Rows.Count, "A").End(xlUp).Row
If Not dict.Exists(Application.Sum(.Rows(d))) Then
dict.Add Key:=Application.Sum(.Rows(d)), _
Item:=Array(.Cells(d, "A").Value2, _
.Cells(d, "B").Value2, _
.Cells(d, "C").Value2)
End If
Next d
For Each k In dict.Keys
.Cells(.Rows.Count, "E").End(xlUp).Resize(1, 3).Offset(1, 0) = dict.Item(k)
Next k
End With
End Sub