VBA 同类求和比较

ms9494

各位大神，请教下：

1 sheet1中的地区&型号需要分类按金额累计求和，sheet2中的地区&型号也需要分类按金额累计求和。

2 两个sheet中地区&型号同类别累计求和数据进行比对，如果累计金额一致，就返回两个sheet的对应的行数和对账列返回"ok"。

由于数据量较大，最好用字典的方法去匹配。累计求和的问题因为论坛上有很多例子已经搞定，现在第二个问题不知道怎写代码。

ms9494

顶上去，搞了一天没搞出来，请教高手

LMY123

ms9494 发表于 2018-12-26 17:02
顶上去，搞了一天没搞出来，请教高手

http://club.excelhome.net/thread-1407531-2-1.html

16楼

39660519

Sub 对账()     Set D = CreateObject("ScrIptIng.DIctIonary")     Set D1 = CreateObject("ScrIptIng.DIctIonary")     Set D2 = CreateObject("ScrIptIng.DIctIonary")          ARR = Sheet1.UsedRange     A = UBound(ARR)     If A > 1 Then         For B = 2 To A             NR = ARR(B, 2) & ARR(B, 3)             D1(NR) = D1(NR) + ARR(B, 4)         Next B     End If          ARR = Sheet2.UsedRange     A = UBound(ARR)     If A > 1 Then         For B = 2 To A             NR = ARR(B, 2) & ARR(B, 3)             ARR(B, 1) = ""             If Not D2.Exists(NR) Then                 D(NR) = B             End If             D2(NR) = D2(NR) + ARR(B, 4)         Next B     End If          For Each C In D.Keys         If D1.Exists(C) And D2.Exists(C) Then             If D1(C) = D2(C) Then                 ARR(D(C), 1) = "OK"             End If         End If     Next C          Sheet2.UsedRange = ARR      End Sub

39660519

Sub 对账()
    Set D = CreateObject("ScrIptIng.DIctIonary")
    Set D1 = CreateObject("ScrIptIng.DIctIonary")
    Set D2 = CreateObject("ScrIptIng.DIctIonary")
   
    ARR = Sheet1.UsedRange
    A = UBound(ARR)
    If A > 1 Then
        For B = 2 To A
            NR = ARR(B, 2) & ARR(B, 3)
            D1(NR) = D1(NR) + ARR(B, 4)
        Next B
    End If
   
    ARR = Sheet2.UsedRange
    A = UBound(ARR)
    If A > 1 Then
        For B = 2 To A
            NR = ARR(B, 2) & ARR(B, 3)
            ARR(B, 1) = ""
            If Not D2.Exists(NR) Then
                D(NR) = B
            End If
            D2(NR) = D2(NR) + ARR(B, 4)
        Next B
    End If
   
    For Each C In D.Keys
        If D1.Exists(C) And D2.Exists(C) Then
            If D1(C) = D2(C) Then
                ARR(D(C), 1) = "OK"
            End If
        End If
    Next C
   
    Sheet2.UsedRange = ARR
   
End Sub

ms9494

39660519 发表于 2018-12-26 17:44
Sub 对账()
    Set D = CreateObject("ScrIptIng.DIctIonary")
    Set D1 = CreateObject("ScrIptIng.D ...

您好，可能我说的不是很清楚，最终实现的效果应该是这样的。sheet1中第二行和第四行对账列返回OK。sheet2中第二行和第四行对账列返回OK。运行了您的代码，只在sheet2中的第二行的对账列返回的OK。能修改下吗，谢谢。

39660519

ms9494 发表于 2018-12-26 20:04
您好，可能我说的不是很清楚，最终实现的效果应该是这样的。sheet1中第二行和第四行对账列返回OK。sheet2 ...

Sub 对账()
   
    Set D1 = CreateObject("ScrIptIng.DIctIonary")
    Set D2 = CreateObject("ScrIptIng.DIctIonary")
    Set D11 = CreateObject("ScrIptIng.DIctIonary")
    Set D22 = CreateObject("ScrIptIng.DIctIonary")
   
    ARR1 = Sheet1.UsedRange
    A = UBound(ARR1)
    If A > 1 Then
        For B = 2 To A
            NR = ARR1(B, 2) & ARR1(B, 3)
            ARR1(B, 1) = ""
            If Not D1.Exists(NR) Then
                D11(NR) = B
            Else
                D11(NR) = D11(NR) & "|" & B
            End If
            D1(NR) = D1(NR) + ARR1(B, 4)
        Next B
    End If
   
    ARR2 = Sheet2.UsedRange
    A = UBound(ARR2)
    If A > 1 Then
        For B = 2 To A
            NR = ARR2(B, 2) & ARR2(B, 3)
            ARR2(B, 1) = ""
            If Not D2.Exists(NR) Then
                D22(NR) = B
            Else
                D22(NR) = D22(NR) & "|" & B
            End If
            D2(NR) = D2(NR) + ARR2(B, 4)
        Next B
    End If
   
    For Each C In D11.Keys
        If D1.Exists(C) And D2.Exists(C) Then
            If D1(C) = D2(C) Then
                S1 = Split(D11(C), "|")
                S2 = Split(D22(C), "|")
                For Each D In S1
                    ARR1(D, 1) = "OK"
                Next D
                For Each D In S2
                    ARR2(D, 1) = "OK"
                Next D
            End If
        End If
    Next C
   
    Sheet1.UsedRange = ARR1
    Sheet2.UsedRange = ARR2
   
End Sub

ms9494

39660519 发表于 2018-12-27 08:37
Sub 对账()
   
    Set D1 = CreateObject("ScrIptIng.DIctIonary")

谢谢，解决了