有两个工作表，均含有相同的数据，但最后一列名称和产品的数量不同，如下图1和图2所示。
图1
图2
现在需要将这两个工作表合并，保留最后一列且添加一列用来存放两个工作表最后一列数据之差，如下图3所示。
图3
这里使用VBA来解决。
由于我们要使用Dictionary对象，因此先要设置相应对象库的引用。首先，打开VBE编辑器，单击菜单“工具——引用”，找到并选取“Microsoft Scripting Runtime”前的复选框，如下图4所示。
图4
编写代码如下：
代码语言：javascript复制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 运行代码后，即可得到上图3所示的结果。
