VBA 如果另一列中的值 = 特定，则对特定列的单元格值求和

Question

我正在尝试对“I”列中的值求和并删除重复行，如果“E”列中的值相同且“G”列中的值是“Kede”。

我有一段我不完全理解的代码，我正试图根据我的需要进行修改。最初这段代码是在“E”列中查找重复值，并对“I”列中的值求和以删除重复行。


'Declare variables
Dim AcSh As Worksheet, LastRow As Long, dict As Object
Dim rngDel As Range, arrE, arrInt, arrI, i As Long, dKey
 
Set AcSh = ActiveSheet
LastRow = AcSh.Range("E" & AcSh.Rows.Count).End(xlUp).Row
 
arrE = AcSh.Range("E2:E" & LastRow).Value
Set dict = CreateObject("Scripting.Dictionary")
 
'Sum and delete duplicates
On Error Resume Next
For i = 1 To UBound(arrE)

    If Not dict.Exists(arrE(i, 1)) Then
    dict.Add arrE(i, 1), AcSh.Range("I" & i + 1).Address & "|" & CDbl(AcSh.Range("I" & i + 1).Value)
    Else
    arrInt = Split(dict(arrE(i, 1)), "|")
    dict(arrE(i, 1)) = arrInt(0) & "|" & CDbl(arrInt(1)) + CDbl(AcSh.Range("I" & i + 1).Value)
    
    If rngDel Is Nothing Then
    Set rngDel = AcSh.Range("E" & i + 1)
    Else
    Set rngDel = Union(rngDel, AcSh.Range("E" & i + 1))
    End If
    End If
    
Next i
 
On Error Resume Next
ReDim arrI(1 To LastRow, 1 To 1)

    For Each dKey In dict.keys()
    arrInt = Split(dict.Item(dKey), "|")
    arrI(Range(arrInt(0)).Row - 1, 1) = CDbl(arrInt(1))
    Next
    If Not rngDel Is Nothing Then
    AcSh.Range("I2").Resize(LastRow - 1, 1).Value = arrI
    rngDel.EntireRow.Delete
    End If

这就是我目前所拥有的


'Declare variables
     Dim AcSh As Worksheet, LastRow As Long, dict As Object
     Dim rngDel As Range, arrG, arrInt, arrI, i As Long, dKey
 
     Set AcSh = ActiveSheet
     LastRow = AcSh.Range("G" & AcSh.Rows.Count).End(xlUp).Row
 
     arrG = AcSh.Range("G2:G" & LastRow).Value
     Set dict = CreateObject("Scripting.Dictionary")

'Sum and delete duplicates
On Error Resume Next
For i = 1 To UBound(arrG)

If Not dict.Exists(arrG(i, 1)) And ThisWorkbook.Worksheets("BOM").Range(i, G).Value = "Kede" Then

dict.Add arrG(i, 1), AcSh.Range("I" & i + 1).Address & "|" & CDbl(AcSh.Range("I" & i + 1).Value)
Else:
arrInt = Split(dict(arrG(i, 1)), "|")
dict(arrG(i, 1)) = arrInt(0) & "|" & CDbl(arrInt(1)) + CDbl(AcSh.Range("I" & i + 1).Value)
    
    If rngDel Is Nothing Then
    Set rngDel = AcSh.Range("G" & i + 1)
    Else:
    Set rngDel = Union(rngDel, AcSh.Range("G" & i + 1))
    End If
End If

Next i

On Error Resume Next
ReDim arrI(1 To LastRow, 1 To 1)

For Each dKey In dict.keys()
    arrInt = Split(dict.Item(dKey), "|")
    arrI(Range(arrInt(0)).Row - 1, 1) = CDbl(arrInt(1))
Next

If Not rngDel Is Nothing Then
AcSh.Range("I2").Resize(LastRow - 1, 1).Value = arrI
rngDel.EntireRow.Delete
End If

所以基本上我是在尝试向原始代码添加一个条件，该条件还会查找“G”列中的值是否为“Kede”。有人可以帮我修改这段代码并向我解释得更清楚吗？

Answer 1

这段代码确实有点混乱。本质上，他们正在制作一个字典，其中的键来自 E:E，值来自 I:I。也许可以对此进行返工，但我可以建议一个更简单的替代方案：数据透视表。它们更灵活，更不容易折断。我整理了一个模拟 sheet 来展示你希望它看起来像：

要自己制作以下内容：

Select 包含数据的列 (E:I)
单击插入 -> 旋转 Table
将 E:E、G:G 和 I:I 列的 header 名称拖到图片中 Column1、Column2 和 Column3 的位置。
更换科德滤镜

希望对您有所帮助！如果您有任何问题，我会尽力提供帮助。

Answer 2

如果我没理解错的话，您想忽略并删除 G 列中没有“Kede”的行。如果是这样，这段代码应该通过在开头删除它们来解决问题。

    'Declare variables
    Dim AcSh As Worksheet, LastRow As Long, dict As Object
    Dim rngDel As Range, arrE, arrInt, arrI, i As Long, dKey
     
 
    Set AcSh = ActiveSheet
    LastRow = AcSh.Range("E" & AcSh.Rows.Count).End(xlUp).Row
    
    'Remove non-Kede rows and reset LastRow
    For i = LastRow + 1 To 2 Step -1
        If AcSh.Range("G" & i).Value <> "Kede" Then AcSh.Range("G" & i).EntireRow.Delete
    Next i
    LastRow = AcSh.Range("E" & AcSh.Rows.Count).End(xlUp).Row
    
    arrE = AcSh.Range("E2:E" & LastRow).Value
    Set dict = CreateObject("Scripting.Dictionary")
     
     
    'Sum and delete duplicates
    On Error Resume Next
    For i = 1 To UBound(arrE)
    
        If Not dict.Exists(arrE(i, 1)) Then
        dict.Add arrE(i, 1), AcSh.Range("I" & i + 1).Address & "|" & CDbl(AcSh.Range("I" & i + 1).Value)
        Else
        arrInt = Split(dict(arrE(i, 1)), "|")
        dict(arrE(i, 1)) = arrInt(0) & "|" & CDbl(arrInt(1)) + CDbl(AcSh.Range("I" & i + 1).Value)
        
        If rngDel Is Nothing Then
        Set rngDel = AcSh.Range("E" & i + 1)
        Else
        Set rngDel = Union(rngDel, AcSh.Range("E" & i + 1))
        End If
        End If
        
    Next i
     
    On Error Resume Next
    ReDim arrI(1 To LastRow, 1 To 1)

    For Each dKey In dict.keys()
    arrInt = Split(dict.Item(dKey), "|")
    arrI(Range(arrInt(0)).Row - 1, 1) = CDbl(arrInt(1))
    Next
    If Not rngDel Is Nothing Then
    AcSh.Range("I2").Resize(LastRow - 1, 1).Value = arrI
    rngDel.EntireRow.Delete
    End If

编辑：感谢下面的评论，我相信我现在明白你的希望了。我很确定这不是解决问题的最 eloquent 方法，但我认为它有效。请尝试。

    'Declare variables
    Dim AcSh As Worksheet, LastRow As Long, dict As Object
    Dim rngDel As Range, arrE, arrInt, arrI, i As Long, dKey
     
    

    
    Set AcSh = ActiveSheet
    LastRow = AcSh.Range("E" & AcSh.Rows.Count).End(xlUp).Row
    
    'Remove non-Kede rows and reset LastRow
   ' For i = LastRow + 1 To 2 Step -1
   '     If AcSh.Range("G" & i).Value <> "Kede" Then AcSh.Range("G" & i).EntireRow.Delete
   ' Next i
    LastRow = AcSh.Range("E" & AcSh.Rows.Count).End(xlUp).Row
    
    arrE = AcSh.Range("E2:E" & LastRow).Value
    arrG = AcSh.Range("G2:G" & LastRow).Value
    Set dict = CreateObject("Scripting.Dictionary")
     
     

    'Sum and delete duplicates
    On Error Resume Next
    For i = 1 To UBound(arrE)
    
        If Not dict.Exists(arrE(i, 1) & arrG(i, 1)) Then
            dict.Add arrE(i, 1) & arrG(i, 1), AcSh.Range("I" & i + 1).Address & "|" & CDbl(AcSh.Range("I" & i + 1).Value)
        ElseIf arrG(i, 1) = "Kede" Then
            arrInt = Split(dict(arrE(i, 1) & arrG(i, 1)), "|")
            dict(arrE(i, 1) & arrG(i, 1)) = arrInt(0) & "|" & CDbl(arrInt(1)) + CDbl(AcSh.Range("I" & i + 1).Value)
            
            If rngDel Is Nothing Then
                Set rngDel = AcSh.Range("E" & i + 1)
            Else
                Set rngDel = Union(rngDel, AcSh.Range("E" & i + 1))
            End If
        Else
            dict.Add AcSh.Range("E" & i + 1).Address, AcSh.Range("I" & i + 1).Address & "|" & CDbl(AcSh.Range("I" & i + 1).Value)
        End If
        
    Next i
     
    On Error Resume Next
    ReDim arrI(1 To LastRow, 1 To 1)

    For Each dKey In dict.keys()
        arrInt = Split(dict.Item(dKey), "|")
        arrI(Range(arrInt(0)).Row - 1, 1) = CDbl(arrInt(1))
    Next
    If Not rngDel Is Nothing Then
        AcSh.Range("I2").Resize(LastRow - 1, 1).Value = arrI
        rngDel.EntireRow.Delete
    End If

VBA 如果另一列中的值 = 特定，则对特定列的单元格值求和

VBA Sum cells values from specific column if value in another column = Specific

excel

vba

sum