怎么根据条件汇总条件范围内数据后且只保留特定条件行

shiruiqiang

他的意思应该这样？
草爷的代码上修改了一下

gwjkkkkk

Option Explicit
Sub TEST1()
    Dim ar, br, cr, i&, j&, r&, vKey, strKey$, dic(1) As New Dictionary, isFlag As Boolean
   
    Application.ScreenUpdating = False
   
    With Worksheets(2)
        ar = Range(.[A1], .UsedRange).Value
        For i = 2 To UBound(ar)
            dic(0)(ar(i, 1)) = "," & Join(Application.Index(ar, i), ",") & ","
        Next i
    End With

    ar = [A1].CurrentRegion.Value
    For i = 2 To UBound(ar)
        If dic(0).exists(ar(i, 1)) Then
            dic(1)(ar(i, 1)) = Array(ar(i, 2), ar(i, 3))
        End If
    Next i
    For i = 2 To UBound(ar)
        If Not dic(1).exists(ar(i, 1)) Then
            isFlag = False
            For Each vKey In dic(0).Keys
                If InStr(dic(0)(vKey), "," & ar(i, 1) & ",") Then
                     strKey = vKey
                     isFlag = True: Exit For
                End If
            Next
            If isFlag Then
                br = dic(1)(strKey)
                br(1) = br(1) + ar(i, 3)
                dic(1)(strKey) = br
            Else
                dic(1)(ar(i, 1)) = Array(ar(i, 2), ar(i, 3))
            End If
        End If
    Next i
   
    ReDim br(1 To dic(1).Count + 1, 1 To 3)
    For j = 1 To UBound(br, 2): br(1, j) = ar(1, j): Next
    r = 1
    For Each vKey In dic(1).Keys
        cr = dic(1)(vKey)
        r = r + 1
        br(r, 1) = vKey
        br(r, 2) = cr(0)
        br(r, 3) = cr(1)
    Next
   
    Columns("G:I").Clear
    [G1].Resize(UBound(br), 3) = br
    Erase dic
    Application.ScreenUpdating = True
    Beep
End Sub

gwjkkkkk

参与一下。。。