|
|
楼主 |
发表于 2024-8-12 09:44
|
显示全部楼层
本帖最后由 758586 于 2024-8-12 11:14 编辑
请各位师傅们帮忙看看 , 下面是自己这些天拼接成的一串代码，能用 但是不能对筛选数据 非连续区域有效，请各位师傅们帮忙修改一下 , 先谢谢各位!
以上求助功能 変换了一下思路 , 对当前活动工作表筛选后的数据，在选中非连续区域分类求和/计数
在选中非连续区域分类求和计数.rar
(19.09 KB, 下载次数: 2)
Sub 分类计数求和计数不能用于筛选数据()
Dim aa As Range
Dim bb As Range
Dim tempSheet As Worksheet
Dim k, s$, i%
Dim x1, r1, d
On Error Resume Next '启动错误处理程序（下一步点击“取消”会发生错误）
MsgBox "注意：不 能 包 含 题 目 行 和 筛 选 数 据 "
' 设置选定区域
If Selection.Cells.Count <= 1 Then
Application.DisplayAlerts = False ' InputBox点击确定报错
Set aa = Application.InputBox("系统 提醒:( 鼠标拖动 选择 分类汇总 区域 ！)", "提 示 ……", , , , , , 8).SpecialCells(xlCellTypeVisible) '筛选后可见数据
If aa.Address = strRngAddress Then MsgBox "未选择单元格 区域 ( 按确定键 退 出 ! )": Exit Sub
Else
Set aa = Selection.SpecialCells(xlCellTypeVisible) '筛选后可见数据
End If
r1 = Application.InputBox(" 偏离 几列 汇总 数量 , 默认偏离 1 列 ", "系统 提示 ……", "1", Type:=2) '指定要批量颜色的目标文字
If r1 = "False" Then Exit Sub
If r1 = "" Then MsgBox "没 有 输 入 字 符 ： 不能 继续 ……": Exit Sub
Set bb = Application.InputBox("系 统 提 醒 :( 选 择 数 据 存 放 单 元 格 ！)", " 提 示 ……", , , , , , 8)
If bb.Address = strRngAddress Then MsgBox "未选择数据存放单元格 !。": Exit Sub
Set d = CreateObject("Scripting.Dictionary")
ARR = aa.Value
For i = 1 To UBound(ARR)
s = ARR(i, 1)
If Not d.exists(s) Then
d(s) = Array(ARR(i, 1), 1, ARR(i, r1 + 1))
Else
k = d(s)
k(1) = k(1) + 1 '计数
k(2) = k(2) + ARR(i, r1 + 1) '求和
d(s) = k
End If
Next
'插入题目行也不对
x1 = bb.Row
x3 = bb.Column
Cells(x1 - 1, x3) = "名 称"
Cells(x1 - 1, x3 + 1) = "计数"
Cells(x1 - 1, x3 + 2) = "合计"
bb.Resize(d.Count, 3) = Application.Rept(d.items, 1) '结果存放
Set d = Nothing
End Sub
|
|
沪公网安备 31011702000001号 沪ICP备11019229号-2
发表于 2024-8-5 21:14
