Excel VBA 在 2 列或更多列的组合中查找唯一值

Question

我正在尝试创建一个带有 for 循环的模块，以计算 3 个组合列的唯一值，这些列包含付款日、月份和年份的状态。所述日期是分开的，因为它们中的每一个都指的是一个月的一个周期，并且所有内容都按照这个确切的顺序按年、月和日排序。就像下面这个简化的小例子一样。

STATUS: DAY : MONTH : YEAR
PAID: 1   : 7     : 2016
OPEN: 1   : 7     : 2016
PAID: 1   : 7     : 2016
OPEN: 5   : 7     : 2016
PAID: 5   : 7     : 2016
OPEN: 5   : 7     : 2016
PAID: 10  : 7     : 2016
OPEN: 10  : 7     : 2016
PAID: 10  : 7     : 2016
PAID: 15  : 7     : 2016
PAID: 15  : 7     : 2016
OPEN: 15  : 7     : 2016

我试图做的是将所有 3 个单元格与列的下一个单元格进行比较，如果它们在所有 3 种情况下都相等，我将简单地计算它以查看我在该日期有多少唯一值并将其保存在一张单独的纸。如果在任何情况下都不同，它只需将日期添加到第二张表并从那里开始计数。为了方便起见，下面的代码进行了简化，因为我正在处理的宏太大而无法在此处发布。 编辑：如果需要，我可以在某处上传完整的代码，我只是翻译一些变量和 cmets。

j = 3 '' variable referencing the next line after i
k = 1 '' variable referencing the lines of the second sheet.
For i = 2 To lastrow ''variable to count how many rows the first sheet has

    j = j + 1 ''variable to check the very next line after i

    If w1.Range("A" & i).Value = "PAID" Then
        If w1.Range("H" & i).Value = w1.Range("H" & j) And w1.Range("G" & i).Value = w1.Range("G" & j) And w1.Range("F" & i).Value = w1.Range("F" & j) Then ''if statement to check if all 3 cells are equal to the next 3 cells 
            w2.Range("D" & K).Value = w2.Range("D" & K).Value + 1 '' Sum 1 to the total number of dates with equal parameters on the 3 cells


        Else '' writes the new date in the second sheet
            K = K + 1
            w2.Range("A" & K).Value = w1.Range("H" & i).Value
            w2.Range("B" & K).Value = w1.Range("G" & i).Value
            w2.Range("C" & K).Value = w1.Range("F" & i).Value
            w2.Range("D" & K).Value = 1

        End If
    End If

Next i

我得到的通常是第一个日期，所有内容都计入新工作表的一行，第二行的最后一行数据。

我也尝试使用字典和/或集合，但我并没有完全理解它们的概念，即使在我在堆栈溢出和互联网上找到的一些示例中也是如此。

我如何使这个循环工作，或者有什么更好的方法来做到这一点？

Answer 1

要从 4 列中获取唯一组合：

Sub uniKue()
    Dim i As Long, N As Long, s As String
    N = Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To N
        Cells(i, 5) = Cells(i, 1) & " " & Cells(i, 2) & " " & Cells(i, 3) & " " & Cells(i, 4)
    Next i

    Range("E2:E" & N).RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

注意：

您可以根据需要将方法扩展到尽可能多的列：

• 连接列
• 使用功能区 数据 选项卡中的 RemoveDuplicates 功能

编辑#1：

这个版本：

Sub uniKue()
    Dim i As Long, N As Long, s As String, r As Range
    N = Cells(Rows.Count, "A").End(xlUp).Row
    For i = 2 To N
        Cells(i, 5) = Cells(i, 1) & " " & Cells(i, 2) & " " & Cells(i, 3) & " " & Cells(i, 4)
        Cells(i, 6) = Cells(i, 5)
    Next i

    Range("F:F").RemoveDuplicates Columns:=1, Header:=xlNo
    For Each r In Range("F:F").SpecialCells(2).Offset(, 1)
        r.Formula = "=COUNTIF(E:E," & r.Offset(, -1).Address & ")"
    Next r
End Sub

生产：

E列是完整的组合集。
F列是唯一集。
G列是数字每个唯一项目的出现次数。

完成后，可以隐藏列 E。

Answer 2

要获得不同的行数 (8)，可以使用这个 Excel 公式（在 VBA 中也是如此）：

=SUMPRODUCT(1 / COUNTIFS(A2:A13,A2:A13, B2:B13,B2:B13, C2:C13,C2:C13, D2:D13,D2:D13) )

获取不重复的唯一行数 (4)：

=SUMPRODUCT(--( COUNTIFS(A2:A13,A2:A13, B2:B13,B2:B13, C2:C13,C2:C13, D2:D13,D2:D13)=1 ))

---

在 VBA 中，可以使用Evaluate 方法计算 Excel 公式：

lastRow = Sheet1.Cells.CurrentRegion.Rows.Count

uniqueCount = Sheet1.Evaluate(Replace( _
      "SUM(--(COUNTIFS(A2:A3,A2:A3,B2:B3,B2:B3,C2:C3,C2:C3,D2:D3,D2:D3)=1))", 3, lastRow))

Debug.Print uniqueCount    ' 4

您还可以一次获取所有行的计数（比分别为每个单元格调用 Excel 更快）：

countsArray = Sheet1.Evaluate(Replace( _
      "Transpose(CountIfs(A2:A9,A2:A9,B2:B9,B2:B9,C2:C9,C2:C9,D2:D9,D2:D9))", 9, lastRow))

' Debug.Print Join(countsArray)   ' "2 1 2 2 1 2 2 1 2 2 2 1"
' Debug.Print Evaluate("SUM(--({" & Join(countsArray, ",") & "}=1))") ' 4
' Debug.Print Evaluate("SUM(1/{" & Join(countsArray, ",") & "})")     ' 8

For i = 2 To lastRow
    If countsArray(i - 1) = 1 Then
        ' ... no dumplicates
    Else
        ' .. has duplicates
    End If
Next i