Question

所以我一直试图从不同的角度解决这个问题并且每次都要撞墙。我不熟悉VBA，所以数据结构也是一个问题。数据透视表实际上不是一个选项，因为我想稍后再添加更多逻辑。

目标是对几张数据进行排序，将与键相关联的2个值相加，输出具有唯一键的列，使用各列的总和输出2列。

例如，输入：

John    10    5    TRUE
Mary    11    7    TRUE
John    1     1    FALSE
Susan   20    9    TRUE
Mary    0     0    TRUE
Susan   2     8    FALSE
John    3     12   TRUE

期望的输出：

John    13    17
Mary    11    7
Susan   20    9

到目前为止，我已经能够extract a list of unique names作为集合，并将其打印出来。为了效率，我想尝试同时进行总和（而不是使用唯一名称作为总和的索引来浏览所有数据）。

据我所知，我不应该使用Collection，因为一旦设置它们就不允许更新项值，并且因为重复的键会引发错误（因此不会让我更新值）。我尝试使用Dictionaries但是有两个对象（每个关联值一个）具有相同的密钥似乎是多余的并且容易出错。在尝试Arrays之前，我想知道我是否在浪费时间，并且有更好的方法/数据结构可供使用，请记住我还需要将这3列输出到单独的表格中，这样很容易打印解决方案将是理想的。

关于我应该怎么做的任何指导？它看起来并不复杂，但我发现很难找到好的文档。提前谢谢！

Answer 1

如果您想使用字典使用VBA，可以尝试以下代码。我拿了你的例子数据并假设他们在A1中开始的sheet1。您需要根据需要修改代码。

主要模块

Option Explicit

Public Sub CreateReport()

    ' Turn off functionality such as auto calculations
    'TurnOffFunctionality

    ' Read the data into a dictionary
    Dim dict As Scripting.Dictionary
    Set dict = ReadFromData()

    ' write the data to the report worksheet
    WriteReport dict

    ' Turn functionality back on
    'TurnOnFunctionality

End Sub

用于读取数据的模块

Option Explicit
Const COL_DATA_NAME = 1
Const COL_VALUE1 = 2
Const COL_VALUE2 = 3
Const COL_ADD = 4

Function ReadFromData() As Scripting.Dictionary

    On Error GoTo EH

    Dim dict As New Scripting.Dictionary

    ' Get the data range
    Dim rgData As Range
    Set rgData = Sheet1.Range("A1:D7")  ' asumption data is in A1:D7

    Dim FirstName As String
    Dim value1 As Long, value2 As Long
    Dim nameCalcs As Calcs
    Dim add As Boolean

    ' Go through each row
    Dim rgCurRow As Range
    For Each rgCurRow In rgData.Rows

        ' Read the row data to variables
        FirstName = rgCurRow.Cells(1, COL_DATA_NAME)
        value1 = rgCurRow.Cells(1, COL_VALUE1)
        value2 = rgCurRow.Cells(1, COL_VALUE2)
        add = rgCurRow.Cells(1, COL_ADD)


        ' If FirstName one is not already in dictionary then add
        If Not dict.Exists(FirstName) Then
            Set nameCalcs = New Calcs
            dict.add FirstName, nameCalcs
        End If

        ' Update the data holder for each FirstName with new values based on the current values
        If add Then
            dict(FirstName).Sum1 = dict(FirstName).Sum1 + value1
            dict(FirstName).Sum2 = dict(FirstName).Sum2 + value2
        End If

    Next rgCurRow

    Set ReadFromData = dict

Done:
    Exit Function
EH:
    ' Your error message
End Function

用于写入数据的模块

Option Explicit
Const REP_COL_FNAME = 1
Const REP_COL_SUM1 = 2
Const REP_COL_SUM2 = 3
Public Sub WriteReport(dict As Scripting.Dictionary)

    On Error GoTo EH

    ' Clear the Report area
    'ClearReportArea   You need to do that on your own

    ' Write the report data
    WriteDataToReport dict

Done:
    Exit Sub
EH:
    MsgBox Err.Description & ". Procedure is: Report_Write.TurnOnFunctionality."
End Sub

Private Sub WriteDataToReport(dict As Scripting.Dictionary)

    On Error GoTo EH

    ' Get variable to track the rows
    Dim rowCnt As Long
    rowCnt = 1

    ' Go through each FirstName in the dictionary
    Dim k As Variant
    For Each k In dict.Keys

        ' Write the data to the report sheet from the data holder
        Dim rgStart As Range
        Set rgStart = Sheet1.Range("F1")
        With dict(k)
            rgStart.Offset(rowCnt, REP_COL_FNAME) = k
            rgStart.Offset(rowCnt, REP_COL_SUM1) = .Sum1
            rgStart.Offset(rowCnt, REP_COL_SUM2) = .Sum2
        End With

        rowCnt = rowCnt + 1

    Next k

Done:
    Exit Sub
EH:
    ' Your error mesaage
End Sub

班级Calcs

Option Explicit

Public Sum1 As Long
Public Sum2 As Long

Answer 2

有一个很小的技巧可以让你有效地做到这一点。

输入数据说在工作表输入中，我们有另一个名为 output 的工作表。

在输出单元格 B1 中输入：

=IF(A1="","",SUMPRODUCT(--(input!$A$1:$A$999=A1)*(input!$D$1:$D$999=TRUE)*(input!$B$1:$B$999)))

并复制下来。在输出单元格 C1 中输入：

=IF(A1="","",SUMPRODUCT(--(input!$A$1:$A$999=A1)*(input!$D$1:$D$999=TRUE)*(input!$C$1:$C$999)))

并向下复制。

输出表现已准备好接收输入表列 A 中的唯一名称（基本上输出中的公式不必重新输入或修改;如果列 A 中没有名称，则 B 和 C 将显示为空）。您可以使用

填充 A 列

Sub GetNames()
    Dim s1 As Worksheet, s2 As Worksheet

    Set s1 = Sheets("input")
    Set s2 = Sheets("output")

    s2.Columns(1).Clear
    s1.Columns(1).Copy s2.Columns(1)
    s2.Columns(1).RemoveDuplicates Columns:=1, Header:=xlNo
End Sub

VBA：列出具有关联值且具有特定条件的唯一项目

2 个答案: