用vba编程提取唯一值及条件合计

dad169

因为用公式太慢了，要求用vba编程提取唯一值及条件合计，谢谢！！！

dad169

牛掰新 发表于 2020-5-28 11:31
楼主把文件发给我

谢谢，这个帖子忘记发文件了，但另一个贴子已经解决了，谢谢！

dad169

牛掰新 发表于 2020-5-28 11:31
楼主把文件发给我

这个文件别人给我别了一半，当是我不会用，一下子给理解不了，无办法修改，所以麻烦你再帮我弄一下，谢谢！！！

dad169

Sub test()
Set d = CreateObject("scripting.dictionary")
Set dc = CreateObject("scripting.dictionary")
With Sheets("1合同")
    r = .Cells(Rows.Count, 4).End(xlUp).Row
    ar = .Range("a4:m" & r)
End With
For i = 2 To UBound(ar)
    If Trim(ar(i, 4)) <> "" Then
        d(Trim(ar(i, 4))) = ""
    End If
Next i
With Sheets("2清单")
    rs = .Cells(Rows.Count, 2).End(xlUp).Row
    br = .Range("a4:s" & rs)
End With
With Sheets("挂靠")
    .[a1].CurrentRegion.Offset(3) = Empty
    .[b4].Resize(d.Count, 1) = Application.Transpose(d.keys)
    y = d.Count + 3
    arr = .Range("a4:i" & y)
    For i = 1 To UBound(arr)
        If Trim(arr(i, 2)) <> "" Then
            m = m + 1
            arr(m, 1) = m
            dc(Trim(arr(i, 2))) = i
        End If
    Next i
    For i = 2 To UBound(ar)
        n = dc(Trim(ar(i, 4)))
        If n <> "" Then
            If Trim(ar(i, 6)) = "已签" Then
                arr(n, 3) = arr(n, 3) + ar(i, 12)
            End If
            If Trim(ar(i, 6)) = "未签" Then
                arr(n, 4) = arr(n, 4) + ar(i, 12)
            End If
        End If
    Next i
    For i = 1 To UBound(br)
        n = dc(Trim(br(i, 8)))
        If n <> "" Then
            If Trim(br(i, 9)) = "已供货" Then
                arr(n, 5) = arr(n, 5) + br(i, 18)
            End If
            If Trim(br(i, 9)) = "已供货" Then
                arr(n, 6) = arr(n, 6) + br(i, 19)
            End If
        End If
    Next i
     .Range("a4:i" & y) = arr
End With
End Sub