Excel精英培训网

 找回密码
 注册
数据透视表40+个常用小技巧,让你一次学会!
12
返回列表 发新帖
楼主: On_fire

VBA高难度的统计

[复制链接]
发表于 2017-5-25 17:09 | 显示全部楼层
注意不要解压缩,直接改扩展名为.xlsm。

Mass.zip

50.1 KB, 下载次数: 4

回复

使用道具 举报

 楼主| 发表于 2017-5-26 13:49 | 显示全部楼层
本帖最后由 On_fire 于 2017-5-26 20:22 编辑
大灰狼1976 发表于 2017-5-25 17:09
注意不要解压缩,直接改扩展名为.xlsm。

老师,

我试出一个问题, 标题行及列, 有更新后,
代码报错(91), 不能执行输出正确统计

ScreenHunter_27272 May. 26.jpg

Mass-TRY.zip

44.68 KB, 下载次数: 6

回复

使用道具 举报

发表于 2017-5-27 20:28 | 显示全部楼层
出错的原因是CODE表内的行标题和列标题没有完全包含DATA表内的数据,因为之前的设计都是按CODE表内行列标题事先输入来做的。如果需要自动根据DATA表数据自动生成的话,代码需要做较大改动,这也是我事先问你用什么方法来做的初衷。
回复

使用道具 举报

 楼主| 发表于 2017-5-27 21:32 | 显示全部楼层
本帖最后由 On_fire 于 2017-5-27 21:34 编辑
大灰狼1976 发表于 2017-5-27 20:28
出错的原因是CODE表内的行标题和列标题没有完全包含DATA表内的数据,因为之前的设计都是按CODE表内行列标题 ...

谢谢老师
我是这样想的,
如果只Data页中的部分交叉的数据统计
那在Code, 输入相关的组合(关键)在标题行及标题, 再执行代码就可以了...

回复

使用道具 举报

发表于 2017-5-27 21:48 | 显示全部楼层
On_fire 发表于 2017-5-27 21:32
谢谢老师… 我是这样想的, 如果只需要Data页中的部分交叉的数据统计…那在Code页, 输入相关的组合(关键字 ...

加个判断就行了。
  1. Sub Mass_TRY()
  2. Dim i&, j&, r&, c&, arr, n&, d As Object, rngr As Range, rngc As Range
  3. Set d = CreateObject("scripting.dictionary")
  4. With Sheets("Code")
  5.   r = .[a65536].End(3).Row + 1
  6.   c = .Cells(2, 16384).End(1).Column
  7.   For j = 2 To c Step 11
  8.     .Cells(3, j).Resize(r - 2, 10).ClearContents
  9.     .Cells(3, j).Resize(r - 2, 10).Interior.Pattern = xlNone
  10.   Next j
  11.   arr = Range("e2:o" & [e65536].End(3).Row)
  12.   For i = 1 To UBound(arr)
  13.     If arr(i, 7) > 5 Then arr(i, 7) = 5
  14.     If arr(i, 11) > 5 Then arr(i, 11) = 5
  15.   Next i
  16.   For i = 1 To UBound(arr)
  17.     Set rngr = .Columns(1).Find(arr(i, 2), lookat:=xlWhole)
  18.     Set rngc = .Rows(1).Find(arr(i, 1), lookat:=xlWhole)
  19.     If Not rngr Is Nothing And Not rngc Is Nothing Then
  20.       r = rngr.Row
  21.       c = rngc.Column
  22.       .Cells(r, c).Offset(, arr(i, 7) - 1) = .Cells(r, c).Offset(, arr(i, 7) - 1) + 1
  23.       .Cells(r, c).Offset(, arr(i, 11) + 4) = .Cells(r, c).Offset(, arr(i, 11) + 4) + 1
  24.       If Not d.exists(arr(i, 1) & "," & arr(i, 2)) Then
  25.         d(arr(i, 1) & "," & arr(i, 2)) = ""
  26.         For j = 1 To UBound(arr)
  27.           If arr(j, 1) = arr(i, 1) Then
  28.             .Cells(r - 1, c).Offset(, arr(j, 7) - 1) = .Cells(r - 1, c).Offset(, arr(j, 7) - 1) + 1
  29.             .Cells(r - 1, c).Offset(, arr(j, 11) + 4) = .Cells(r - 1, c).Offset(, arr(j, 11) + 4) + 1
  30.           End If
  31.           If arr(j, 2) = arr(i, 2) Then
  32.             .Cells(r + 1, c).Offset(, arr(j, 7) - 1) = .Cells(r + 1, c).Offset(, arr(j, 7) - 1) + 1
  33.             .Cells(r + 1, c).Offset(, arr(j, 11) + 4) = .Cells(r + 1, c).Offset(, arr(j, 11) + 4) + 1
  34.           End If
  35.         Next j
  36.       End If
  37.     End If
  38.   Next i
  39. End With
  40. End Sub
复制代码


回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-3-29 17:26 , Processed in 0.751724 second(s), 10 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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