Excel应用实践22： 比较并合并工作表

Sub CombineSheets()
    '声明变量
    '用于存储工作表Sheet1中的数据
    Dim dic1 As Scripting.Dictionary
    '用于存储工作表Sheet2中的数据
    Dim dic2 As Scripting.Dictionary
    '工作表Sheet1
    Dim wks1 As Worksheet
    '工作表Sheet2
    Dim wks2 As Worksheet
    '工作表Sheet3
    Dim wks3 As Worksheet
    '工作表中数据的最后一行
    Dim lngLastRow As Long
    Dim i As Long
    Dim j As Long
    Dim var As Variant
    '入库数量
    Dim dblImport As Double
    '出库数量
    Dim dblExport As Double
    Dim rng1 As Range
    Dim rng2 As Range
   
    '赋值工作表对象
    Set wks1 = Sheets("Sheet1")
    Set wks2 = Sheets("Sheet2")
    Set wks3 = Sheets("Sheet3")
   
    '初始化字典对象
    Set dic1 = New Scripting.Dictionary
    Set dic2 = New Scripting.Dictionary
   
    '填充字典dic1
    lngLastRow = wks1.Range("A" &Rows.Count).End(xlUp).Row
    Set dic1 =DicData(wks1.Range("A1:E" & lngLastRow), 2, True)
   
    '填充字典dic2
    lngLastRow = wks2.Range("A" &Rows.Count).End(xlUp).Row
    Set dic2 = DicData(wks2.Range("A1:E"& lngLastRow), 2, True)
   
    '将数据输入到工作表Sheet3
    wks3.Rows("2:" &Rows.Count).Clear
    i = 1
    '遍历字典dic1
    For Each var In dic1.Keys
        dblImport = 0
        '取第5列中的入库数据并求和
        For Each rng1 In dic1.Item(var).Rows
            dblImport = dblImport +rng1.Cells(5)
        Next rng1
       
        '输出数据到相应的单元格
        i = i + 1
        For Each rng2 Indic1.Item(var).Rows(1).Cells
            wks3.Cells(i, rng2.Column) = rng2
        Next rng2
        wks3.Cells(i, 5) = dblImport
        wks3.Cells(i, 1) = i - 1
    Next var
   
    For Each var In dic2.Keys
        dblExport = 0
        '取第5列中的出库数据并求和
        For Each rng1 In dic2.Item(var).Rows
            dblExport = dblExport +rng1.Cells(5)
        Next rng1
       
        '输出数据到相应的单元格中并计算出入库差
        lngLastRow = wks3.Range("A"& Rows.Count).End(xlUp).Row
        For j = 2 To lngLastRow
            If dic2.Item(var).Cells(1, 2) =wks3.Cells(j, 2) Then
                wks3.Cells(j, 6) = dblExport
                wks3.Cells(j, 7).Formula ="=" & _
                     wks3.Cells(j, 5).Address& "-" & _
                     wks3.Cells(j, 6).Address
                Exit For
            End If
        Next j
    Next var
End Sub
 
'使用指定区域的数据填充字典
Function DicData(rngInput AsRange, _
  ColIndex As Long, _
  blnHeaders As Boolean) AsScripting.Dictionary
    Dim i As Long
    Dim cell As Range
    Dim rng As Range
    Dim rngTemp As Range
    Dim dic As Scripting.Dictionary
    Dim strVal As String
   
    Application.ScreenUpdating = False
   
    Set rng = rngInput.Columns(ColIndex)
    Set dic = New Scripting.Dictionary
   
    '文本比较,不区分大小写
    dic.CompareMode = TextCompare
   
    '是否有标题
    If blnHeaders Then
        With rngInput
            Set rngInput = .Offset(1,0).Resize( _
              .Rows.Count - 1, .Columns.Count)
        End With
    End If
   
    With rngInput
        For Each cell In.Columns(ColIndex).Cells
            i = i + 1
            strVal = cell.Text
            If Not dic.Exists(strVal) Then
                dic.Add strVal, .Rows(i)
            Else
                '将前几列具有相同数据的行存储在同一字典键
                Set rngTemp = Union(.Rows(i),dic(strVal))
                dic.Remove strVal
                dic.Add strVal, rngTemp
            End If
        Next cell
    End With
   
    Set DicData = dic
    Application.ScreenUpdating = True
End Function