设为首页收藏本站
开启辅助访问

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 分表按要求合并数据求助
数据透视表40+个常用小技巧，让你一次学会！
12下一页
返回列表 发新帖
查看: 3968|回复: 11

[已解决]分表按要求合并数据求助

[复制链接]
发表于 2016-2-16 14:56 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
分表按要求合并数据求助
最佳答案
月排行榜 / 总排行榜
sry660
2016-2-17 09:23
野蛮女 发表于 2016-2-17 08:03
详见附件
谢谢

已调整，请测试
  1. Sub 汇总()
  2.     Dim arr, i&, d, d1, x, k&, imax&
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Set d1 = CreateObject("scripting.dictionary")
  5.     Sheets(2).[b2:k10000].Clear
  6.     For k = 3 To Sheets.Count
  7.         With Sheets(k)
  8.             imax = .Cells(Rows.Count, 3).End(xlUp).Row
  9.             .Range("a2:a" & imax) = .Name
  10.             arr = .[a1].CurrentRegion
  11.             For i = 2 To UBound(arr)
  12.                 x = arr(i, 2)
  13.                 If Len(x) Then
  14.                     If Not d.exists(x) Then
  15.                         Set d(x) = .Cells(i, 1).Resize(1, 9)
  16.                         d1(x) = ""
  17.                     Else
  18.                         Set d(x) = Union(d(x), .Cells(i, 1).Resize(1, 9))
  19.                     End If
  20.                 End If
  21.             Next
  22.             For Each x In d1.keys
  23.                 With Sheets(2)
  24.                     If d.exists(x) Then d(x).Copy .Cells(Rows.Count, 2).End(xlUp).Offset(1)
  25.                 End With
  26.             Next
  27.             d.RemoveAll
  28.             d1.RemoveAll
  29.         End With
  30.     Next
  31.     With Sheets(2)
  32.         imax = .Cells(Rows.Count, 3).End(xlUp).Row
  33.         With Sheets(2).Range("b1:k" & imax)
  34.             .Sort key1:=[c1], order1:=xlAscending, Header:=xlYes
  35.         End With
  36.     End With
  37. End Sub
复制代码

20160208出差统计.rar

29.18 KB, 下载次数: 10
excel精英培训的微信平台，每天都会发送excel学习教程和资料。扫一扫明天就可以收到新教程
回复

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
sry660
发表于 2016-2-16 18:10 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
  1. Sub 汇总()
  2.     Dim arr, i&, d, d1, x, k&, imax&
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Set d1 = CreateObject("scripting.dictionary")
  5.     Sheets(2).[b2:k10000].Clear
  6.     For k = 3 To Sheets.Count
  7.         With Sheets(k)
  8.             imax = .Cells(Rows.Count, 3).End(xlUp).Row
  9.             .Range("a2:a" & imax) = .Name
  10.             arr = .[a1].CurrentRegion
  11.             For i = 2 To UBound(arr)
  12.                 x = arr(i, 2)
  13.                 If Len(x) Then
  14.                     If Not d.exists(x) Then
  15.                         Set d(x) = .Cells(i, 1).Resize(1, 10)
  16.                         d1(x) = ""
  17.                     Else
  18.                         Set d(x) = Union(d(x), .Cells(i, 1).Resize(1, 10))
  19.                     End If
  20.                 End If
  21.             Next
  22.             For Each x In d1.keys
  23.                 With Sheets(2)
  24.                     If d.exists(x) Then d(x).Copy .Cells(Rows.Count, 2).End(xlUp).Offset(1)
  25.                     d.RemoveAll
  26.                     d1.RemoveAll
  27.                 End With
  28.             Next
  29.         End With
  30.     Next
  31.     With Sheets(2)
  32.         imax = .Cells(Rows.Count, 3).End(xlUp).Row
  33.         With Sheets(2).Range("b1:k" & imax)
  34.             .Sort key1:=[c1], order1:=xlAscending, Header:=xlYes
  35.         End With
  36.     End With
  37. End Sub
复制代码

20160208出差统计.rar

64.27 KB, 下载次数: 9

评分

参与人数 1 +1 收起 理由
野蛮女 + 1 很给力

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2016-2-16 22:07 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
sry660 发表于 2016-2-16 18:10

第一个表数据继续录入后无法更新
回复

使用道具 举报

sry660
发表于 2016-2-16 22:45 | 显示全部楼层
野蛮女 发表于 2016-2-16 22:07
第一个表数据继续录入后无法更新

没明白你的意思，最好将你录入数据的附件传上来，说明效果
回复

使用道具 举报

 楼主| 发表于 2016-2-17 08:03 | 显示全部楼层
sry660 发表于 2016-2-16 22:45
没明白你的意思，最好将你录入数据的附件传上来，说明效果

详见附件
谢谢

20160208出差统计.rar

73.34 KB, 下载次数: 5
回复

使用道具 举报

sry660
发表于 2016-2-17 09:23 | 显示全部楼层    本楼为最佳答案   
野蛮女 发表于 2016-2-17 08:03
详见附件
谢谢

已调整，请测试
  1. Sub 汇总()
  2.     Dim arr, i&, d, d1, x, k&, imax&
  3.     Set d = CreateObject("scripting.dictionary")
  4.     Set d1 = CreateObject("scripting.dictionary")
  5.     Sheets(2).[b2:k10000].Clear
  6.     For k = 3 To Sheets.Count
  7.         With Sheets(k)
  8.             imax = .Cells(Rows.Count, 3).End(xlUp).Row
  9.             .Range("a2:a" & imax) = .Name
  10.             arr = .[a1].CurrentRegion
  11.             For i = 2 To UBound(arr)
  12.                 x = arr(i, 2)
  13.                 If Len(x) Then
  14.                     If Not d.exists(x) Then
  15.                         Set d(x) = .Cells(i, 1).Resize(1, 9)
  16.                         d1(x) = ""
  17.                     Else
  18.                         Set d(x) = Union(d(x), .Cells(i, 1).Resize(1, 9))
  19.                     End If
  20.                 End If
  21.             Next
  22.             For Each x In d1.keys
  23.                 With Sheets(2)
  24.                     If d.exists(x) Then d(x).Copy .Cells(Rows.Count, 2).End(xlUp).Offset(1)
  25.                 End With
  26.             Next
  27.             d.RemoveAll
  28.             d1.RemoveAll
  29.         End With
  30.     Next
  31.     With Sheets(2)
  32.         imax = .Cells(Rows.Count, 3).End(xlUp).Row
  33.         With Sheets(2).Range("b1:k" & imax)
  34.             .Sort key1:=[c1], order1:=xlAscending, Header:=xlYes
  35.         End With
  36.     End With
  37. End Sub
复制代码

20160208出差统计.rar

73.53 KB, 下载次数: 10
回复

使用道具 举报

yuhe0008
发表于 2016-2-17 09:51 | 显示全部楼层
你的贴子中原来不是用了SQL了吗？在VBA中union一下不就行了？

20160208出差统计.rar

39.58 KB, 下载次数: 9

评分

参与人数 1 +1 收起 理由
野蛮女 + 1 赞一个

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2016-2-17 12:15 | 显示全部楼层
yuhe0008 发表于 2016-2-17 09:51
你的贴子中原来不是用了SQL了吗？在VBA中union一下不就行了？

数据损坏，看不到，不会。。。
回复

使用道具 举报

yuhe0008
发表于 2016-2-17 12:27 | 显示全部楼层
野蛮女 发表于 2016-2-17 12:15
数据损坏，看不到，不会。。。

20160208出差统计.rar (101.65 KB, 下载次数: 12)
回复

使用道具 举报

 楼主| 发表于 2016-2-17 12:57 | 显示全部楼层
本帖最后由 野蛮女 于 2016-2-17 14:07 编辑
yuhe0008 发表于 2016-2-17 12:27

可以了，但是分表还会不断的增加。。。
回复

使用道具 举报

下一页 »
12下一页
返回列表 发新帖
高级模式
B Color Image Link Quote Code Smilies
您需要登录后才可以回帖 登录 | 注册

本版积分规则

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

GMT+8, 2024-5-19 09:30 , Processed in 0.341597 second(s), 16 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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