前往小程序,Get更优阅读体验!
立即前往
首页
学习
活动
专区
工具
TVP
发布
社区首页 >专栏 >Excel应用实践22: 比较并合并工作表

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

作者头像
fanjy
发布2019-10-22 13:57:21
7300
发布2019-10-22 13:57:21
举报
文章被收录于专栏:完美Excel

有两个工作表,均含有相同的数据,但最后一列名称和产品的数量不同,如下图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所示的结果。

代码的图片版如下:
本文参与 腾讯云自媒体同步曝光计划,分享自微信公众号。
原始发表:2019-10-17,如有侵权请联系 cloudcommunity@tencent.com 删除

本文分享自 完美Excel 微信公众号,前往查看

如有侵权,请联系 cloudcommunity@tencent.com 删除。

本文参与 腾讯云自媒体同步曝光计划  ,欢迎热爱写作的你一起参与!

评论
登录后参与评论
0 条评论
热度
最新
推荐阅读
领券
问题归档专栏文章快讯文章归档关键词归档开发者手册归档开发者手册 Section 归档