Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
查看: 4026|回复: 3

请求大神赐我一段代码!满足多个条件后,值相加汇总后删除行

[复制链接]
发表于 2017-11-6 16:18 | 显示全部楼层 |阅读模式
单号
L
W
H
数量
17083105
10
9
50
17083105
12
8
50
17083105
12
15
21
100
17083105
12
15
21
100
17083105
12
15
21
25
17083105
17
7
100
17083105
19.5
14.5
100
17083105
30
4
80
17083105
30
7
40
17083105
30
7
40
17083105
50
16
20
17083105
51
51
4
40
17083105
51
51
4
320

如上表,希望当L,W,H都相等的时候,数量一列相加且只保留一行,另外多余的行自动删除,达到如下表所示效果。

单号
L
W
H
数量
17083105
10
9
50
17083105
12
8
50
17083105
12
15
21
225
17083105
17
7
100
17083105
19.5
14.5
100
17083105
30
4
80
17083105
30
7
80
17083105
50
16
20
17083105
51
51
4
360

XIEXIE!.zip

13.04 KB, 下载次数: 6

原文件

 楼主| 发表于 2017-11-8 11:10 | 显示全部楼层
回复

使用道具 举报

发表于 2017-11-8 19:23 | 显示全部楼层
Public Sub DealWith()
    Dim arr As Variant, brr As Variant, crr As Variant, i As Integer, k As Integer, s As Integer, dic As Object
   
    '清理sheet1中的数据
    Sheet1.Range("A1").CurrentRegion.ClearContents
   
    '获取工作表1中的数据
    arr = 工作表5.Range("A1").CurrentRegion.Value
   
    '创建字典
    Set dic = CreateObject("Scripting.Dictionary")
   
    '利用字典删除重复项,同时累加求和
    For i = 1 To UBound(arr, 1)
        dic(arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)) = dic(arr(i, 1) & "," & arr(i, 2) & "," & arr(i, 3) & "," & arr(i, 4)) + arr(i, 5)
    Next i

    '将删除重复项后的内容赋值到数组变量brr
    brr = Application.WorksheetFunction.Transpose(dic.Keys)
   
    '利用循环及Split函数重新构建一个数组(单号、L、W、H)并赋值给数组变量crr
    ReDim crr(1 To dic.Count + 1, 1 To 4)
    For k = 1 To UBound(brr, 1)
        For s = 1 To 4
            crr(k, s) = Split(brr(k, 1), ",")(s - 1)
        Next s
    Next k
   
    '将结果输出到工作表sheet1中
    With Sheet1.Range("A1")
        .Resize(UBound(crr, 1), UBound(crr, 2)).Value = crr
        .Offset(0, 4).Resize(dic.Count, 1).Value = Application.WorksheetFunction.Transpose(dic.Items)
    End With
   
    '调整工作表sheet1的列宽/居中
    With Sheet1.Columns("A:E")
        .AutoFit
        .HorizontalAlignment = xlCenter
        .VerticalAlignment = xlCenter
    End With
   
End Sub

评分

参与人数 1学分 +1 收起 理由
韩立 + 1 学习了

查看全部评分

回复

使用道具 举报

发表于 2017-11-8 19:26 | 显示全部楼层
绿卡816-沸点 发表于 2017-11-8 19:23
Public Sub DealWith()
    Dim arr As Variant, brr As Variant, crr As Variant, i As Integer, k As In ...

给你

删除求和.rar

22.48 KB, 下载次数: 18

回复

使用道具 举报

您需要登录后才可以回帖 登录 | 注册

本版积分规则

小黑屋|手机版|Archiver|Excel精英培训 ( 豫ICP备11015029号 )

GMT+8, 2024-3-28 16:56 , Processed in 1.967591 second(s), 15 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

快速回复 返回顶部 返回列表