[已解决]求修改代码计算当前可见单元格求合

楚雪飞扬

请教下各位老师要如何修改代码只计算当前可见单格元数量
现有VBA代码是把所有单格数值全部算进去，这部份要怎么修改？
此表格数据是从表1（数据源）得出的结果代码在模块4

最佳答案

月排行榜 / 总排行榜

cutecpu

2021-10-18 14:36

加 红色部份 即可！

Sub demo()
   Set d = CreateObject("Scripting.Dictionary")
   a = Sheet1.UsedRange
   For i = 3 To UBound(a)
      r = r + 1: If Sheet1.[a2].Offset(r).EntireRow.Hidden Then GoTo 1
      Key = a(i, 1)
      If Not d.exists(Key) Then
         d(Key) = Array(Key, a(i, 2), a(i, 3), a(i, 4), a(i, 5))
      Else
         d(Key) = Array(Key, d(Key)(1), d(Key)(2) + a(i, 3), d(Key)(3) + a(i, 4), d(Key)(4) + a(i, 5))
      End If
1: Next
   Sheet4.UsedRange.Offset(1, 0).ClearContents
   Sheet4.[a2].Resize(d.Count, 5) = Application.Transpose(Application.Transpose(d.Items))
   ary = Range("a65536").End(xlUp).Row
For i = 2 To ary
   Cells(i, 6) = Cells(i, 5) / Cells(i, 3)
Next
End Sub

跳转到最佳答案楼层

心正意诚身修

你太省事了。。。。你是啥说明也没有。里面四个模块，好多个SUB过程。还要让人去把所有的读完了。再想去猜你想实现的效果？
你不是应该先设身处地的为别人考虑么？毕竟 大家的时间都是有限且宝贵的。

楚雪飞扬

心正意诚身修 发表于 2021-10-18 14:03
你太省事了。。。。你是啥说明也没有。里面四个模块，好多个SUB过程。还要让人去把所有的读完了。再想去猜 ...

抱歉，代码在模块4里

cutecpu

加 红色部份 即可！

Sub demo()
   Set d = CreateObject("Scripting.Dictionary")
   a = Sheet1.UsedRange
   For i = 3 To UBound(a)
      r = r + 1: If Sheet1.[a2].Offset(r).EntireRow.Hidden Then GoTo 1
      Key = a(i, 1)
      If Not d.exists(Key) Then
         d(Key) = Array(Key, a(i, 2), a(i, 3), a(i, 4), a(i, 5))
      Else
         d(Key) = Array(Key, d(Key)(1), d(Key)(2) + a(i, 3), d(Key)(3) + a(i, 4), d(Key)(4) + a(i, 5))
      End If
1: Next
   Sheet4.UsedRange.Offset(1, 0).ClearContents
   Sheet4.[a2].Resize(d.Count, 5) = Application.Transpose(Application.Transpose(d.Items))
   ary = Range("a65536").End(xlUp).Row
For i = 2 To ary
   Cells(i, 6) = Cells(i, 5) / Cells(i, 3)
Next
End Sub

心正意诚身修

cutecpu 发表于 2021-10-18 14:36
加 红色部份 即可！

Sub demo()

你真是太棒了。。我还在写呢。我想的是。。我先循环判断行高是否为0，如果不是，那么生成一个新的数组A，还原他原来的的USEDRANGE，加这么一个循环和判断 。。你只加一句话就解决了。

楚雪飞扬

cutecpu 发表于 2021-10-18 14:36
加 红色部份 即可！

Sub demo()

非常感谢，在从网上找代码，一直找不到合适，太感谢了！