有两个工作表，均含有相同的数据，但最后一列名称和产品的数量不同，如下图1和图2所示。

图1

图2

现在需要将这两个工作表合并，保留最后一列且添加一列用来存放两个工作表最后一列数据之差，如下图3所示。

图3

这里使用VBA来解决。

由于我们要使用Dictionary对象，因此先要设置相应对象库的引用。首先，打开VBE编辑器，单击菜单“工具——引用”，找到并选取“Microsoft Scripting Runtime”前的复选框，如下图4所示。

图4

编写代码如下：

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所示的结果。

代码的图片版如下：

阅读全文