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

Excel精英培训网

 找回密码
 注册
Excel精英培训网»论坛 › Excel 求助区 › Excel VBA开发 › 用VBA怎么实现附件中的多条件查找统计，并且不能重复计 ...
数据透视表40+个常用小技巧，让你一次学会！
返回列表 发新帖
查看: 4280|回复: 4

[已解决]用VBA怎么实现附件中的多条件查找统计，并且不能重复计数

[复制链接]
发表于 2014-5-14 00:39 | 显示全部楼层 |阅读模式
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
【求助】请问用VBA怎么实现附件中的多条件查找统计，根据sheet“地市清单"中的“基站名称”统计基站个数，因为每个基站名称对应几个小区，而我们只需要统计不同基站的个数，同一个基站名称只能算1个（相当于根据“基站名称”扩展去重之后再统计一样，即只统计1次，不重复计数）;
按条件统计不同基站个数
主要条件有：
A列/所属厂家，
B列/地市，
F/是否完成单验（找出"是"的个数），对应前面的[sheet统计汇总]中的"单验数"
G/是否内部验收通过（找出"是"的个数），，对应前面的[sheet统计汇总]中的"内部验收数"
I/是否完成单优（找出"是"的个数），，对应前面的[sheet统计汇总]中的"单优数"
J/所属规划期，对应前面的[sheet统计汇总]中第2行的"试验网"/"LTE-1"/"LTE-1增补"/"F升级"/"F共模"
K/站点类型，对应前面的[sheet统计汇总]中的"室外"/"室内"

其它说明，[sheet统计汇总]中
C列规模为固定值；
D列=各期单验数"小计"之和,即D=K+T+AC+AL+AU,E列、F列类似D；
G列（内验比例）=E列（内部验收数）/C列（规模）；
H列（单优比例）=F列（单优数）/E列（内部验收数）；

有点复杂，我们每周统计3次，数据量目前约十几万行，还在增加，用公式查找统计容易卡死，打开慢，能否帮忙写成VBA代码，加快计算速度，提前说声谢谢了。
由于限制附件大小，附件中的清单数，只是少数，可以用于验证代码是否有问题。
最佳答案
月排行榜 / 总排行榜
grf1973
2014-5-14 15:03
  1. Sub 统计()
  2.     Call UnMergeRng   '拆分合并的单元格
  3.     arr = Sheet2.[a1].CurrentRegion
  4.     Set d = CreateObject("scripting.dictionary")
  5.     Set d1 = CreateObject("scripting.dictionary")
  6.     For i = 3 To UBound(arr)
  7.         jz = Trim(arr(i, 4)) '基站
  8.         If Not d1.exists(jz) Then
  9.             d1(jz) = ""
  10.             xkey = Trim(arr(i, 2)) & Trim(arr(i, 1)) & Trim(arr(i, 10)) & Trim(arr(i, 11))    '地市+厂家+规划期+站点类型 （计算I---BA列）
  11.             xkey1 = Trim(arr(i, 2)) & "合计" & Trim(arr(i, 10)) & Trim(arr(i, 11))    '地市+合计+规划期+站点类型（计算I---BA列的合计行）
  12.             xkey2 = Trim(arr(i, 2)) & Trim(arr(i, 1))    '地市+厂家 （计算DEF列）
  13.             xkey3 = Trim(arr(i, 2)) & "合计"    '地市+合计   （计算DEF列的合计行）
  14.             If Trim(arr(i, 6)) = "是" Then
  15.                 d(xkey & "单验数") = d(xkey & "单验数") + 1
  16.                 d(xkey1 & "单验数") = d(xkey1 & "单验数") + 1
  17.                 d(xkey2 & "单验数") = d(xkey2 & "单验数") + 1
  18.                 d(xkey3 & "单验数") = d(xkey3 & "单验数") + 1
  19.             End If
  20.             If Trim(arr(i, 7)) = "是" Then
  21.                 d(xkey & "内部验收数") = d(xkey & "内部验收数") + 1
  22.                 d(xkey1 & "内部验收数") = d(xkey1 & "内部验收数") + 1
  23.                 d(xkey2 & "内部验收数") = d(xkey2 & "内部验收数") + 1
  24.                 d(xkey3 & "内部验收数") = d(xkey3 & "内部验收数") + 1
  25.             End If
  26.             If Trim(arr(i, 9)) = "是" Then
  27.                 d(xkey & "单优数") = d(xkey & "单优数") + 1
  28.                 d(xkey1 & "单优数") = d(xkey1 & "单优数") + 1
  29.                 d(xkey2 & "单优数") = d(xkey2 & "单优数") + 1
  30.                 d(xkey3 & "单优数") = d(xkey3 & "单优数") + 1
  31.             End If
  32.         End If
  33.     Next
  34.     With Sheet1
  35.         .[d5:ba34].ClearContents
  36.         arr = .[a1:ba34]
  37.         For i = 6 To UBound(arr)
  38.             For j = 4 To UBound(arr, 2)
  39.                 If j < 9 Then   'DEF列
  40.                     xkey = Trim(arr(i, 1)) & Trim(arr(i, 2)) & Trim(arr(4, j))   '地市+厂家+进展情况
  41.                 Else    'I--BA列
  42.                     xkey = Trim(arr(i, 1)) & Trim(arr(i, 2)) & Trim(arr(2, j)) & Trim(arr(4, j)) & Trim(arr(3, j))    '地市+厂家+规划期+站点类型+进展情况
  43.                 End If
  44.                 arr(i, j) = d(xkey)    '根据不同的xkey赋值
  45.                 If arr(4, j) = "小计" Then   '小计列
  46.                     If arr(i, j - 1) + arr(i, j - 2) > 0 Then arr(i, j) = arr(i, j - 1) + arr(i, j - 2)
  47.                 End If
  48.                
  49.                 arr(5, j) = arr(5, j) + arr(i, j)    '总量相加
  50.                 If arr(i, 2) = "合计" Then arr(5, j) = arr(5, j) - arr(i, j)   '总量去掉合计数即为全省
  51.             Next
  52.             If arr(i, 4) > 0 Then    '计算比例
  53.                 arr(i, 7) = arr(i, 5) / arr(i, 4)
  54.                 arr(i, 8) = arr(i, 6) / arr(i, 4)
  55.             End If
  56.         Next
  57.         If arr(5, 4) > 0 Then   '计算第5行比例
  58.                 arr(5, 7) = arr(5, 5) / arr(5, 4)
  59.                 arr(5, 8) = arr(5, 6) / arr(5, 4)
  60.             End If
  61.         .[a1:ba34] = arr
  62.     End With
  63.     Call MergeRng   '重新合并单元格
  64.         
  65. End Sub
  66. Sub UnMergeRng()    '拆分合并的单元格
  67.       Dim StrMer As String
  68.       Dim IntCot As Integer
  69.       Dim i As Integer
  70.       With ActiveSheet
  71.           For Each cel In .Range("a6:a34")   'A列分离
  72.               StrMer = cel.Value
  73.               IntCot = cel.MergeArea.Count
  74.               If IntCot > 1 Then
  75.               cel.UnMerge
  76.               cel.Resize(IntCot, 1).Value = StrMer
  77.               End If
  78.           Next
  79.           For Each cel In .Range("I2:Ba3")   '第二、三行分离
  80.               StrMer = cel.Value
  81.               IntCot = cel.MergeArea.Count
  82.               If IntCot > 1 Then
  83.               cel.UnMerge
  84.               cel.Resize(1, IntCot).Value = StrMer
  85.               End If
  86.           Next
  87.          
  88.       End With
  89.   End Sub

  91. Sub MergeRng()    '合并相同内容的单元格
  92.       Dim IntRow As Integer
  93.       Dim i As Integer
  94.       Application.DisplayAlerts = False
  95.       With ActiveSheet
  96.           For i = 34 To 7 Step -1   'A列合并
  97.             If .Cells(i, 1) = .Cells(i - 1, 1) Then .Cells(i - 1, 1).Resize(2, 1).Merge
  98.           Next
  99.           For i = 53 To 10 Step -1
  100.             If .Cells(2, i) = .Cells(2, i - 1) Then .Cells(2, i - 1).Resize(1, 2).Merge    '第二行合并
  101.             If .Cells(3, i) = .Cells(3, i - 1) Then .Cells(3, i - 1).Resize(1, 2).Merge    '第三行合并
  102.           Next
  103.       End With
  104.       Application.DisplayAlerts = True
  105.   End Sub
  106. Sub 清空()
  107.     Sheet1.[d5:ba34].ClearContents
  108. End Sub
复制代码
统计, 规模, 汇总表, VBA

广东LTE开网优化站点信息表_【汇总】.rar

32.17 KB, 下载次数: 18

请在附件中直接添加VBA

相关帖子

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

使用道具 举报

工作中最常用的函数公式，全印在一张超大的鼠标垫上
grf1973
发表于 2014-5-14 09:29 | 显示全部楼层
工作中常用的Excel函数公式，全印在一张超大鼠标垫上
标注。有空弄。多弄两个字典就可以搞定的。
回复

使用道具 举报

 楼主| 发表于 2014-5-14 12:06 | 显示全部楼层
工作中最常用的Excel函数公式，全印在一张鼠标垫上
grf1973 发表于 2014-5-14 09:29
标注。有空弄。多弄两个字典就可以搞定的。

谢谢，麻烦抽空搞搞，比较急需，我要下发模版给各地市的相关负责人。
回复

使用道具 举报

grf1973
发表于 2014-5-14 15:03 | 显示全部楼层    本楼为最佳答案   
  1. Sub 统计()
  2.     Call UnMergeRng   '拆分合并的单元格
  3.     arr = Sheet2.[a1].CurrentRegion
  4.     Set d = CreateObject("scripting.dictionary")
  5.     Set d1 = CreateObject("scripting.dictionary")
  6.     For i = 3 To UBound(arr)
  7.         jz = Trim(arr(i, 4)) '基站
  8.         If Not d1.exists(jz) Then
  9.             d1(jz) = ""
  10.             xkey = Trim(arr(i, 2)) & Trim(arr(i, 1)) & Trim(arr(i, 10)) & Trim(arr(i, 11))    '地市+厂家+规划期+站点类型 （计算I---BA列）
  11.             xkey1 = Trim(arr(i, 2)) & "合计" & Trim(arr(i, 10)) & Trim(arr(i, 11))    '地市+合计+规划期+站点类型（计算I---BA列的合计行）
  12.             xkey2 = Trim(arr(i, 2)) & Trim(arr(i, 1))    '地市+厂家 （计算DEF列）
  13.             xkey3 = Trim(arr(i, 2)) & "合计"    '地市+合计   （计算DEF列的合计行）
  14.             If Trim(arr(i, 6)) = "是" Then
  15.                 d(xkey & "单验数") = d(xkey & "单验数") + 1
  16.                 d(xkey1 & "单验数") = d(xkey1 & "单验数") + 1
  17.                 d(xkey2 & "单验数") = d(xkey2 & "单验数") + 1
  18.                 d(xkey3 & "单验数") = d(xkey3 & "单验数") + 1
  19.             End If
  20.             If Trim(arr(i, 7)) = "是" Then
  21.                 d(xkey & "内部验收数") = d(xkey & "内部验收数") + 1
  22.                 d(xkey1 & "内部验收数") = d(xkey1 & "内部验收数") + 1
  23.                 d(xkey2 & "内部验收数") = d(xkey2 & "内部验收数") + 1
  24.                 d(xkey3 & "内部验收数") = d(xkey3 & "内部验收数") + 1
  25.             End If
  26.             If Trim(arr(i, 9)) = "是" Then
  27.                 d(xkey & "单优数") = d(xkey & "单优数") + 1
  28.                 d(xkey1 & "单优数") = d(xkey1 & "单优数") + 1
  29.                 d(xkey2 & "单优数") = d(xkey2 & "单优数") + 1
  30.                 d(xkey3 & "单优数") = d(xkey3 & "单优数") + 1
  31.             End If
  32.         End If
  33.     Next
  34.     With Sheet1
  35.         .[d5:ba34].ClearContents
  36.         arr = .[a1:ba34]
  37.         For i = 6 To UBound(arr)
  38.             For j = 4 To UBound(arr, 2)
  39.                 If j < 9 Then   'DEF列
  40.                     xkey = Trim(arr(i, 1)) & Trim(arr(i, 2)) & Trim(arr(4, j))   '地市+厂家+进展情况
  41.                 Else    'I--BA列
  42.                     xkey = Trim(arr(i, 1)) & Trim(arr(i, 2)) & Trim(arr(2, j)) & Trim(arr(4, j)) & Trim(arr(3, j))    '地市+厂家+规划期+站点类型+进展情况
  43.                 End If
  44.                 arr(i, j) = d(xkey)    '根据不同的xkey赋值
  45.                 If arr(4, j) = "小计" Then   '小计列
  46.                     If arr(i, j - 1) + arr(i, j - 2) > 0 Then arr(i, j) = arr(i, j - 1) + arr(i, j - 2)
  47.                 End If
  48.                
  49.                 arr(5, j) = arr(5, j) + arr(i, j)    '总量相加
  50.                 If arr(i, 2) = "合计" Then arr(5, j) = arr(5, j) - arr(i, j)   '总量去掉合计数即为全省
  51.             Next
  52.             If arr(i, 4) > 0 Then    '计算比例
  53.                 arr(i, 7) = arr(i, 5) / arr(i, 4)
  54.                 arr(i, 8) = arr(i, 6) / arr(i, 4)
  55.             End If
  56.         Next
  57.         If arr(5, 4) > 0 Then   '计算第5行比例
  58.                 arr(5, 7) = arr(5, 5) / arr(5, 4)
  59.                 arr(5, 8) = arr(5, 6) / arr(5, 4)
  60.             End If
  61.         .[a1:ba34] = arr
  62.     End With
  63.     Call MergeRng   '重新合并单元格
  64.         
  65. End Sub
  66. Sub UnMergeRng()    '拆分合并的单元格
  67.       Dim StrMer As String
  68.       Dim IntCot As Integer
  69.       Dim i As Integer
  70.       With ActiveSheet
  71.           For Each cel In .Range("a6:a34")   'A列分离
  72.               StrMer = cel.Value
  73.               IntCot = cel.MergeArea.Count
  74.               If IntCot > 1 Then
  75.               cel.UnMerge
  76.               cel.Resize(IntCot, 1).Value = StrMer
  77.               End If
  78.           Next
  79.           For Each cel In .Range("I2:Ba3")   '第二、三行分离
  80.               StrMer = cel.Value
  81.               IntCot = cel.MergeArea.Count
  82.               If IntCot > 1 Then
  83.               cel.UnMerge
  84.               cel.Resize(1, IntCot).Value = StrMer
  85.               End If
  86.           Next
  87.          
  88.       End With
  89.   End Sub

  91. Sub MergeRng()    '合并相同内容的单元格
  92.       Dim IntRow As Integer
  93.       Dim i As Integer
  94.       Application.DisplayAlerts = False
  95.       With ActiveSheet
  96.           For i = 34 To 7 Step -1   'A列合并
  97.             If .Cells(i, 1) = .Cells(i - 1, 1) Then .Cells(i - 1, 1).Resize(2, 1).Merge
  98.           Next
  99.           For i = 53 To 10 Step -1
  100.             If .Cells(2, i) = .Cells(2, i - 1) Then .Cells(2, i - 1).Resize(1, 2).Merge    '第二行合并
  101.             If .Cells(3, i) = .Cells(3, i - 1) Then .Cells(3, i - 1).Resize(1, 2).Merge    '第三行合并
  102.           Next
  103.       End With
  104.       Application.DisplayAlerts = True
  105.   End Sub
  106. Sub 清空()
  107.     Sheet1.[d5:ba34].ClearContents
  108. End Sub
复制代码
回复

使用道具 举报

grf1973
发表于 2014-5-14 15:05 | 显示全部楼层
表格的数组定义是按照你的工作表来的，并未智能判断工作表大小。如果需要代码可以再改。
由于表1中有好多合并单元格，不利于字典的使用，因此先把合并单元格拆分成相同内容的单元格再进行统计，统计完后再合并。

广东LTE开网优化站点信息表_【汇总】.rar

55.05 KB, 下载次数: 30
回复

使用道具 举报

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

本版积分规则

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

GMT+8, 2024-4-17 04:21 , Processed in 0.169006 second(s), 13 queries , Gzip On, Yac On.

Powered by Discuz! X3.4

Copyright © 2001-2020, Tencent Cloud.

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