【代码】往来账清账勾对，字典实例详解，把多个单元格区域组合装入字典

Sub billCheck()    Dim ws As Worksheet, rng As Range, row As Range, Area As Range    Dim cArea As Range, dArea As Range, cRow As Range, dRow As Range    Dim lRow As Long    Dim lCol As Integer    Dim cTotal As Double, dTotal As Double    Dim dic As Object, dkey    Dim bgColor1 As Double, bgColor2 As Double    bgColor1 = RGB(173, 255, 47)    bgColor2 = RGB(255, 235, 205)    Set ws = ThisWorkbook.Sheets("Sheet1")    Set dic = CreateObject("Scripting.Dictionary")        '//把相同供应商业务编号所在行组合成一个Range，装入字典    With ws        lRow = .UsedRange.Rows.Count        lCol = 6        For i = 2 To lRow            If .Cells(i, 2) <> "" Then                .Cells(i, lCol) = ""                dkey = .Cells(i, 2) & "|" & .Cells(i, 3)                If Not dic.exists(dkey) Then                    Set rng = .Cells(i, 1).Resize(1, lCol)                Else                    Set rng = dic(dkey)                    Set rng = Union(rng, .Cells(i, 1).Resize(1, lCol))                End If                Set dic(dkey) = rng            End If        Next    End With

    '//循环字典的每一个key,把item取出来进行勾对处理    For Each dkey In dic.keys        Set rng = dic(dkey)        rng.Interior.Color = xlNone        dTotal = 0: cTotal = 0                '//先汇总借、贷方金额        For Each Area In rng.Areas            For Each row In Area.Rows                dTotal = dTotal + row.Cells(1, 4)                cTotal = cTotal + row.Cells(1, 5)            Next        Next        If dTotal = cTotal Then                        '//如果借贷方汇总金额相同，两清，勾对所有            For Each Area In rng.Areas                For Each row In Area.Rows                    row.Cells(1, lCol) = "y"                    row.Interior.Color = bgColor1                Next            Next        Else                        '//如果借、贷方汇总金额不等，再进行明细勾对            For Each dArea In rng.Areas                For Each dRow In dArea.Rows                    dTotal = dRow.Cells(1, 4)                    If dTotal <> 0 Then  '//排除借方为0的记录                        For Each cArea In rng.Areas                            For Each cRow In cArea.Rows                                cTotal = cRow.Cells(1, 5)                                If dTotal = cTotal And cRow.Cells(1, lCol) <> "y" Then                                                                        '//如果借贷相等，且贷方没有被勾对过                                    dRow.Cells(1, lCol) = "y"                                    dRow.Interior.Color = bgColor2                                    cRow.Cells(1, lCol) = "y"                                    cRow.Interior.Color = bgColor2                                                                        '//勾对一条记录就退出循环，防止把其他相同金额也勾对                                    GoTo nextRow                                End If                            Next                        Next                    End IfnextRow:                Next            Next        End If    Next    MsgBox "Done!"End Sub