VBA Excel – 如何删除重复的组合
我写了一个代码，用数字列表编写所有可能的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
我怎么能把这个逻辑在我的代码？
而不是摆脱重复，为什么不避免输出他们开始？
而不是从min开始的第二个和第三个循环，让他们从前一个循环variables开始。 下面是我嘲笑的一个类似的工作例子：
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
尝试下面的代码。 我添加了一些代码来合并3个单元格，并将答案放在第5列中。然后我按第5列sorting。下一个循环使用总计并删除每次总共更改时重复的总数…… 。
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
使用字典来收集唯一的总和作为键和单个值作为数组项，然后将数组写回工作表。
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
