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

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

3 个答案: