【问题标题】:VBA: List unique items with associated values and given certain conditionsVBA:列出具有关联值并给定特定条件的唯一项目
【发布时间】:2018-01-31 03:52:41
【问题描述】:

所以我一直在尝试从不同的角度解决这个问题,并且每次都碰壁。我不熟悉 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,但有2个对象(每个关联值一个)具有相同的键似乎是多余的且容易出错。在尝试Arrays 之前,我想知道我是否在浪费时间并且有更好的方法/数据结构可供使用,请记住,我还需要将这 3 列输出到单独的工作表中,以便于打印解决方案将是理想的。

关于我应该如何做的任何指导?它看起来真的没有那么复杂,但我发现很难找到好的文档。提前致谢!

【问题讨论】:

  • 您可以使用数据透视表并过滤掉错误

标签: excel vba


【解决方案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

【讨论】:

    【解决方案2】:

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

    说输入数据在工作表 input 中,我们还有另一个名为 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 中没有名称,则 BC 将显示为空)。您可以使用以下内容填充列 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
    

    【讨论】:

      猜你喜欢
      • 1970-01-01
      • 2014-08-24
      • 1970-01-01
      • 1970-01-01
      • 1970-01-01
      • 1970-01-01
      • 2021-10-07
      • 2022-01-27
      • 2021-06-03
      相关资源
      最近更新 更多