根据多个条件计算不同的值

Posted 2023-03-22

【中文标题】根据多个条件计算不同的值

【英文标题】：Count distinct values based on multiple criteria

【发布时间】：2021-08-24 06:42:48

【问题描述】：

我的 Excel 工作簿具有一个包含大约 50K 记录的表。我目前正在使用一个公式来计算基于两个标准的不同值，即：ID & Region

通过公式执行此操作会使我的工作簿变得异常缓慢。因此，我想知道您是否知道如何将其转换为高效的 VBA 循环。

.Range("C2").Formula = "=IF(IFERROR(1=SUMPRODUCT(1/COUNTIFS($A$2:A2,A2,$B$2:B2,B2)),0),1,0)"

C 列中的所需结果。VBA 代码必须能够通过用“1”标记 C 列来突出显示唯一值。当遇到重复条目时，代码只能将范围的最后一个条目标记为唯一的“1”（请参阅​​ ID 3）。

【问题讨论】：

结果是否按您显示的那样排序？对于 VBA，我建议将数据读入 VBA 数组；然后使用 Dictionary 对象检查重复项。

我突然想到，创建此列可能不是您想要的最终结果。例如，如果您打算将其用作过滤器，以便仅返回最后一个唯一值，则在 VBA 或 Power Query 中都有更有效的方法来完成此操作。

【参考方案1】：

独特的“降序”

假定表格（一行标题）从单元格A1 开始，并且标题已写入目标（结果）列的第一个单元格 (dCol)。 调整工作表名称 (wsName) 和目标列 (dCol)。 Delimiter 必须是不包含在数据中的字符串。

Option Explicit

Sub GetUnique()
    
    Const wsName As String = "Sheet1"
    Const dCol As String = "C"
    Const Delimiter As String = "|"
    
    Dim wb As Workbook: Set wb = ThisWorkbook ' workbook containing this code
    Dim ws As Worksheet: Set ws = wb.Worksheets(wsName)
    
    Dim srg As Range
    With ws.Range("A1").CurrentRegion
        Set srg = .Resize(.Rows.Count - 1, 2).Offset(1)
    End With
    Dim sData As Variant: sData = srg.Value
    
    Dim rCount As Long: rCount = srg.Rows.Count
    Dim dData As Variant: ReDim dData(1 To rCount, 1 To 1)
    
    Dim dict As Object: Set dict = CreateObject("Scripting.Dictionary")
    dict.CompareMode = vbTextCompare
    
    Dim r As Long
    Dim cString As String
    
    For r = rCount To 1 Step -1
        cString = sData(r, 1) & Delimiter & sData(r, 2)
        If dict.Exists(cString) Then
            dData(r, 1) = 0
        Else
            dict.Add cString, Empty
            dData(r, 1) = 1
        End If
    Next r
    
    Dim drg As Range: Set drg = srg.Resize(, 1).EntireRow.Columns(dCol)
    drg.Value = dData

    With drg
        .Resize(ws.Rows.Count - rCount - 1).Offset(rCount).ClearContents
    End With
    
End Sub