VBA Excel -如何删除重复的组合

Question

我写了一段代码，用一个数字列表用3个数字写出所有可能的组合。

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

这可以很好地工作。但是，我需要删除所有重复的组合(与顺序无关)

例如，如果我有这样的组合：

16 | 17 | 18
16 | 18 | 17
18 | 17 | 17
18 | 16 | 16

在删除之后，我应该会得到这样的输出：

16 | 17 | 18
18 | 17 | 17
18 | 16 | 16

如何将此逻辑放入我的代码中？

Answer 1

与其丢弃重复的文件，为什么不从一开始就避免输出它们呢？

让第二个和第三个循环从前一个循环变量开始，而不是从min开始。下面是我模拟的一个类似的工作示例：

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

这将在“即时”窗口中打印以下内容：

 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

尝试下面的代码。我添加了一些代码来将3个单元格相加，并将答案放在第5列。然后按第5列排序。下一个循环使用合计，并在每次合计发生变化时删除任何重复的合计......

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        

单元格(1，5).EntireColumn.ClearContents

Answer 3

使用字典收集唯一的总和作为键，将各个值作为数组项，然后将数组写回工作表。

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

​

​