有两个工作表,均含有相同的数据,但最后一列名称和产品的数量不同,如下图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
文章内容收集于网络,希望能为您提供帮助。强国说-WPS之家(wps.qiangguoshuo.com)
‘工作表中数据的最后一行
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所示的结果。
代码的图片版如下:
转载声明:本站发布文章及版权归原作者所有,转载本站文章请注明文章来源!