Excel精英培训网

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

[已解决](高级!)批量 一对多对应及统计

[复制链接]
发表于 2017-4-20 22:41 | 显示全部楼层 |阅读模式
求高手出现啊!!!
本人之前已熬了无数个夜晚,做了无数次透视图,就是无法做到预期的那样啊!
之前做过这样的工作:每个缺陷项都填上对应的条款和条款内容,进行透视,但是因为部分条款没有对应的缺陷项,所以这些没有对应缺陷项的条款就不会在透视表中出现,但是,我是希望这些条款不管有没有对应的缺陷项,都出现在最后的表中,并进行统计~
(图片不知为什么,不能上传了。。。可详见此贴:http://www.excelpx.com/thread-429541-1-1.html(一开始似乎发错地方了,所以重新发了个贴))

要求:
1.将《缺陷统计分析表》中的“缺陷及问题”和“产品类别”对应到《指导原则》中的“条款”和“条款内容”中去。
2.统计该条款对应有多少条缺陷项。
3.《缺陷统计分析表》中的“缺陷及问题”和“产品类别”和《指导原则》中的“条款”和“条款内容”都不能少。

说明:
1.有的条款会对应多个缺陷项,有的条款没有对应的缺陷项。
2.“条款”和“条款内容”是唯一对应的。

无论用函数、透视表等等,什么手段都可以,就是希望能批量处理,因为实在太多了!
非常感谢!!!!

最佳答案
2017-4-21 14:04
附件请测试。
  1. Private Sub CommandButton1_Click()
  2. Dim arr, brr, crr, drr, i&, j&, d As Object, r&
  3. Set d = CreateObject("scripting.dictionary")
  4. arr = Sheets(1).[a1].CurrentRegion
  5. brr = Sheets(2).[a1].CurrentRegion
  6. ReDim crr(1 To UBound(arr) + UBound(brr), 1 To 6)
  7. For i = 2 To UBound(arr)
  8.   d(arr(i, 4)) = d(arr(i, 4)) & "," & i
  9. Next i
  10. For i = 2 To UBound(brr)
  11.   r = r + 1
  12.   crr(r, 1) = brr(i, 1)
  13.   crr(r, 2) = brr(i, 2)
  14.   crr(r, 3) = brr(i, 3)
  15.   If d.exists(brr(i, 2)) Then
  16.     drr = Split(d(brr(i, 2)), ",")
  17.     For j = 1 To UBound(drr)
  18.       crr(r, 4) = arr(drr(j), 5)
  19.       crr(r, 5) = arr(drr(j), 2)
  20.       If j = 1 Then crr(r, 6) = UBound(drr)
  21.       If UBound(drr) > j Then r = r + 1
  22.     Next j
  23.   Else
  24.     crr(r, 6) = 0
  25.   End If
  26. Next i
  27. [a2].Resize(r, 6) = crr
  28. End Sub
复制代码

求助.rar

117.41 KB, 下载次数: 15

 楼主| 发表于 2017-4-20 22:43 | 显示全部楼层
为啥分到了excel常见模块中???那似乎又发错地方了。。。
初来乍到,有点迷路
回复

使用道具 举报

发表于 2017-4-21 14:04 | 显示全部楼层    本楼为最佳答案   
附件请测试。
  1. Private Sub CommandButton1_Click()
  2. Dim arr, brr, crr, drr, i&, j&, d As Object, r&
  3. Set d = CreateObject("scripting.dictionary")
  4. arr = Sheets(1).[a1].CurrentRegion
  5. brr = Sheets(2).[a1].CurrentRegion
  6. ReDim crr(1 To UBound(arr) + UBound(brr), 1 To 6)
  7. For i = 2 To UBound(arr)
  8.   d(arr(i, 4)) = d(arr(i, 4)) & "," & i
  9. Next i
  10. For i = 2 To UBound(brr)
  11.   r = r + 1
  12.   crr(r, 1) = brr(i, 1)
  13.   crr(r, 2) = brr(i, 2)
  14.   crr(r, 3) = brr(i, 3)
  15.   If d.exists(brr(i, 2)) Then
  16.     drr = Split(d(brr(i, 2)), ",")
  17.     For j = 1 To UBound(drr)
  18.       crr(r, 4) = arr(drr(j), 5)
  19.       crr(r, 5) = arr(drr(j), 2)
  20.       If j = 1 Then crr(r, 6) = UBound(drr)
  21.       If UBound(drr) > j Then r = r + 1
  22.     Next j
  23.   Else
  24.     crr(r, 6) = 0
  25.   End If
  26. Next i
  27. [a2].Resize(r, 6) = crr
  28. End Sub
复制代码

test.zip

204.12 KB, 下载次数: 30

评分

参与人数 1 +1 收起 理由
gb168 + 1 赞一个

查看全部评分

回复

使用道具 举报

 楼主| 发表于 2017-4-21 20:24 | 显示全部楼层
非常感谢您的回复,我先去试试
回复

使用道具 举报

 楼主| 发表于 2017-4-21 21:07 | 显示全部楼层
非常感谢大神!已经弄出来了!但其实对于里面的语句是一窍不通,是照着描了一下,后面打算需要好好学习一下语言,不过燃眉之急已解。
另外,不知大神是否有方法可以保留原格式?比如我其中一张表中,一个单元格中第一段是不加粗,第二段是加粗的,这种格式可否保留?
回复

使用道具 举报

发表于 2017-4-21 21:09 | 显示全部楼层
如果没有特殊意义不建议保留格式,会导致文件庞大,
并且要保留格式的话,必须逐个单元格操作,代码复杂不说,
运行速度是非常慢的。
回复

使用道具 举报

 楼主| 发表于 2017-4-21 21:51 | 显示全部楼层
其实特殊意义还是有点的,不过既然代码会很复杂,文件很庞大的话,那还是算了,谢谢大神
回复

使用道具 举报

发表于 2017-4-24 11:32 | 显示全部楼层
典型的一对多,数据库内连接。
QQ截图20170424112835.png

求助.rar

130.16 KB, 下载次数: 6

回复

使用道具 举报

发表于 2017-4-24 14:38 | 显示全部楼层
  1. Sub tt()     '保留条款内容的格式
  2.     Application.ScreenUpdating = False
  3.     Set d = CreateObject("scripting.dictionary")
  4.     arr = Sheets(1).[a1].CurrentRegion
  5.     For i = 2 To UBound(arr)
  6.       d(arr(i, 4)) = d(arr(i, 4)) & "," & i
  7.     Next i
  8.     With ActiveSheet
  9.         .Cells.ClearContents
  10.         .Cells.Borders.LineStyle = 0
  11.         Sheets("指导原则").[a1].CurrentRegion.Copy .[a1]
  12.         .[d1].Resize(1, 3) = Array("缺陷及问题", "产品类别", "该条款缺陷项计数")
  13.         brr = .[a1].CurrentRegion
  14.         For i = UBound(brr) To 2 Step -1
  15.             x = brr(i, 2)
  16.             If d.exists(x) Then
  17.                 xrr = Split(d(x), ","): p = UBound(xrr)
  18.                 If p > 1 Then .Rows(i + 1).Resize(p - 1).Insert
  19.                 For kk = 1 To p
  20.                     k = xrr(kk)
  21.                     .Cells(i + kk - 1, 4) = arr(k, 5)
  22.                     .Cells(i + kk - 1, 5) = arr(k, 2)
  23.                     If kk = 1 Then .Cells(i, 6) = p
  24.                 Next
  25.             Else
  26.                 .Cells(i, 6) = 0
  27.             End If
  28.         Next
  29.         .[a1].CurrentRegion.Borders.LineStyle = 1
  30.     End With
  31.     Application.ScreenUpdating = True
  32. End Sub
复制代码

求助.rar

143.74 KB, 下载次数: 25

回复

使用道具 举报

 楼主| 发表于 2017-5-2 10:21 | 显示全部楼层

谢谢大神!试了一下感觉很好用!
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 14:15 , Processed in 0.407084 second(s), 14 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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